Start9/start-os
2
0
Fork 0
mirror of https://github.com/Start9Labs/start-os.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #69 from Start9Labs/agent/bugfix/ecc-synchronizer

Browse Source 
actually adds ecc sync to the list
This commit is contained in:
Keagan McClelland
2020-12-01 13:30:18 -07:00
committed by GitHub
parent 116c8a9b67 45dbfc59e1
commit 3630ae0677
5 changed files with 131 additions and 118 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
agent/src/Application.hs
View File

@@ -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)
--------------------------------------------------------------

19
agent/src/Daemon/SslRenew.hs
View File

@@ -13,8 +13,8 @@ import Lib.Ssl
import Daemon.ZeroConf ( getStart9AgentHostname )
import Lib.Tor
import Control.Carrier.Lift
import System.Directory ( renameDirectory
, removeDirectory
import System.Directory ( removePathForcibly
, renameDirectory
)
import Lib.SystemCtl
import qualified Lib.Notifications as Notifications
@@ -25,10 +25,11 @@ import Constants
renewSslLeafCert :: AgentCtx -> IO ()
renewSslLeafCert ctx = do
let base = appFilesystemBase . appSettings $ ctx
hn <- injectFilesystemBase base getStart9AgentHostname
sid <- injectFilesystemBase base getStart9AgentHostname
let hostname = sid <> ".local"
tor <- injectFilesystemBase base getAgentHiddenServiceUrl
putStr @Text "SSL Renewal Required? "
needsRenew <- doesSslNeedRenew (toS $ entityCertPath hn `relativeTo` base)
needsRenew <- doesSslNeedRenew (toS $ entityCertPath sid `relativeTo` base)
print needsRenew
when needsRenew $ runM . injectFilesystemBase base $ do
intCaKeyPath <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
@@ -36,9 +37,9 @@ renewSslLeafCert ctx = do
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)
entKeyPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath sid)
entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath sid)
entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath sid)
(ec, out, err) <- writeLeafCert
DeriveCertificate { applicantConfPath = entConfPathTmp
@@ -49,7 +50,7 @@ renewSslLeafCert ctx = do
, signingCertPath = intCaCertPath
, duration = 365
}
hn
hostname
tor
liftIO $ do
putStrLn @Text "openssl logs"
@@ -66,7 +67,7 @@ renewSslLeafCert ctx = do
$ Notifications.emit (AppId "EmbassyOS") agentVersion
$ Notifications.CertRenewFailed (ExitFailure n) out err
let sslDir = toS $ sslDirectory `relativeTo` base
liftIO $ removeDirectory sslDir
liftIO $ removePathForcibly sslDir
liftIO $ renameDirectory sslDirTmp sslDir
liftIO $ systemCtl RestartService "nginx" $> ()

71
agent/src/Handler/Register/Nginx.hs
View File

@@ -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" $> ()

57
agent/src/Lib/Error.hs
View File

@@ -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

100
agent/src/Lib/Synchronizers.hs
View File

@@ -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
@@ -116,6 +118,7 @@ sync_0_2_6 = Synchronizer
, syncPrepSslRootCaDir
, syncPrepSslIntermediateCaDir
, syncPersistLogs
, syncConvertEcdsaCerts
]
syncCreateAgentTmp :: SyncOp
@@ -445,12 +448,93 @@ syncConvertEcdsaCerts :: SyncOp
syncConvertEcdsaCerts = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False
where
check = do
fs <- asks $ appFilesystemBase . appSettings
header <- liftIO $ headMay . lines <$> readFile (toS $ intermediateCaKeyPath `relativeTo` fs)
pure $ case header of
Nothing -> False
Just y -> "BEGIN RSA PRIVATE KEY" `T.isInfixOf` y
migrate = replaceDerivativeCerts
fs <- asks $ appFilesystemBase . appSettings
let intCertKey = toS $ intermediateCaKeyPath `relativeTo` fs
exists <- liftIO $ doesPathExist intCertKey
if exists
then do
header <- liftIO $ headMay . lines <$> readFile intCertKey
pure $ case header of
Nothing -> False
Just y -> "BEGIN RSA PRIVATE KEY" `T.isInfixOf` y
else pure False
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
sid <- getStart9AgentHostname
let hostname = sid <> ".local"
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 sid)
entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath sid)
entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath sid)
liftIO $ createDirectoryIfMissing True sslDirTmp
liftIO $ BS.writeFile entConfPathTmp (domain_CSR_CONF hostname)
-- 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
}
hostname
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 $ removePathForcibly sslDir
liftIO $ renameDirectory sslDirTmp sslDir
liftIO $ systemCtl RestartService "nginx" $> ()
failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) ()
failUpdate e = do