From b4b2ec6d9908217af08310d48f4485614717ebaf Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 27 Nov 2020 11:13:04 -0700 Subject: [PATCH 01/11] adds timing instruments to see why setup takes so long --- agent/src/Application.hs | 4 +- agent/src/Handler/Register.hs | 46 ++++++---- agent/src/Handler/Register/Nginx.hs | 20 ++++- agent/src/Lib/Ssl.hs | 131 +++++++++++++++++----------- 4 files changed, 132 insertions(+), 69 deletions(-) diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 1be93162b..27326812e 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -81,10 +81,10 @@ appMain = do die . toS $ "Invalid Port: " <> n ["--git-hash"] -> do putStrLn @Text $embedGitRevision - exitWith ExitSuccess + exitSuccess ["--version"] -> do putStrLn @Text (show agentVersion) - exitWith ExitSuccess + exitSuccess _ -> pure settings createDirectoryIfMissing False (toS $ agentDataDirectory `relativeTo` appFilesystemBase settings') diff --git a/agent/src/Handler/Register.hs b/agent/src/Handler/Register.hs index a6a2c24a5..f40bec097 100644 --- a/agent/src/Handler/Register.hs +++ b/agent/src/Handler/Register.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Handler.Register where @@ -31,44 +32,59 @@ import Lib.SystemPaths import Model import Settings -postRegisterR :: Handler RegisterRes -postRegisterR = handleS9ErrT $ do - settings <- getsYesod appSettings - productKey <- liftIO . getProductKey . appFilesystemBase $ settings - req <- requireCheckJsonBody +postRegisterR :: Handler RegisterRes +postRegisterR = handleS9ErrT . fromSys $ do + time "Start" + settings <- getsYesod appSettings + + productKey <- liftIO . getProductKey . appFilesystemBase $ settings + time "Read Product Key" + req <- requireCheckJsonBody + time "Parse JSON Body" -- Decrypt torkey and password. This acts as product key authentication. - torKeyFileContents <- decryptTorkey productKey req - password <- decryptPassword productKey req - rsaKeyFileContents <- decryptRSAKey productKey req + torKeyFileContents <- lift $ decryptTorkey productKey req + time "Decrypt Tor Key" + password <- lift $ decryptPassword productKey req + time "Decrypt Password" + rsaKeyFileContents <- lift $ decryptRSAKey productKey req + time "Decrypto RSA" -- Check for existing registration. - checkExistingPasswordRegistration rootAccountName >>= \case + lift $ checkExistingPasswordRegistration rootAccountName >>= \case Nothing -> pure () Just _ -> sendResponseStatus (Status 209 "Preexisting") () + time "Check Password Registration" -- install new tor hidden service key and restart tor - registerResTorAddress <- runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case - Just t -> pure t - Nothing -> throwE TorServiceTimeoutE + registerResTorAddress <- + lift $ runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case + Just t -> pure t + Nothing -> throwE TorServiceTimeoutE + time "Bootstrap Tor Hidden Service" -- install new ssl CA cert + nginx conf and restart nginx registerResCert <- - runM . handleS9ErrC . (>>= liftEither) . liftIO . runM . injectFilesystemBaseFromContext settings $ do + runM . handleS9ErrC . liftEither <=< liftIO . runM . injectFilesystemBaseFromContext settings $ do bootupHttpNginx runError @S9Error $ bootupSslNginx rsaKeyFileContents + time "Bootstrap SSL Configuration" -- create an hmac of the torAddress + caCert for front end registerResTorAddressSig <- produceProofOfKey productKey registerResTorAddress - registerResCertSig <- produceProofOfKey productKey registerResCert + time "Sign Tor Address" + registerResCertSig <- produceProofOfKey productKey registerResCert + time "Sign Certificate" -- must match CN in config/csr.conf let registerResCertName = root_CA_CERT_NAME registerResLanAddress <- runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostnameLocal + time "Fetch Agent Hostname" -- registration successful, save the password hash - registerResClaimedAt <- saveAccountRegistration rootAccountName password + registerResClaimedAt <- lift $ saveAccountRegistration rootAccountName password + time "Save Account Registration" pure RegisterRes { .. } diff --git a/agent/src/Handler/Register/Nginx.hs b/agent/src/Handler/Register/Nginx.hs index 59b4da6bc..2307c2740 100644 --- a/agent/src/Handler/Register/Nginx.hs +++ b/agent/src/Handler/Register/Nginx.hs @@ -21,6 +21,19 @@ import Lib.Synchronizers import Lib.SystemPaths import Lib.Tor import System.Posix ( removeLink ) +import Data.String.Interpolate.IsString + ( i ) + +time :: MonadIO m => Text -> StateT UTCTime m () +time t = do + last <- Startlude.get + now <- liftIO getCurrentTime + putStrLn @Text [i|#{t}: #{diffUTCTime now last}|] + put now + +fromSys :: MonadIO m => StateT UTCTime m a -> m a +fromSys m = liftIO getCurrentTime >>= evalStateT m + -- Left error, Right CA cert for hmac signing bootupSslNginx :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, Has (Lift IO) sig m, MonadIO m) @@ -74,7 +87,7 @@ resetSslState = do >>= traverse_ removePathForcibly writeFile (toS $ flip relativeTo base $ rootCaDirectory <> "/index.txt") "" writeFile (toS $ flip relativeTo base $ intermediateCaDirectory <> "/index.txt") "" - _ <- liftIO $ try @SomeException . removeLink . toS $ (nginxSitesEnabled nginxSslConf) `relativeTo` base + _ <- liftIO $ try @SomeException . removeLink . toS $ nginxSitesEnabled nginxSslConf `relativeTo` base pure () @@ -82,7 +95,7 @@ bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m () bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf" writeSslKeyAndCert :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => ByteString -> m Text -writeSslKeyAndCert rsaKeyFileContents = do +writeSslKeyAndCert rsaKeyFileContents = fromSys $ do directory <- toS <$> getAbsoluteLocationFor sslDirectory caKeyPath <- toS <$> getAbsoluteLocationFor rootCaKeyPath caConfPath <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath @@ -98,10 +111,13 @@ writeSslKeyAndCert rsaKeyFileContents = do let hostname = sid <> ".local" + time "SSL Start" liftIO $ createDirectoryIfMissing False directory liftIO $ BS.writeFile caKeyPath rsaKeyFileContents + time "Write SSL Root Key" (exit, str1, str2) <- writeRootCaCert caConfPath caKeyPath caCertPath + time "Generate SSL Root Cert" liftIO $ do putStrLn @Text "openssl logs" putStrLn @Text "exit code: " diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index 37dea7a5d..94e5f82bb 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -1,6 +1,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} -module Lib.Ssl where +module Lib.Ssl + ( DeriveCertificate(..) + , root_CA_CERT_NAME + , writeRootCaCert + , writeIntermediateCert + , domain_CSR_CONF + , writeLeafCert + , root_CA_OPENSSL_CONF + , intermediate_CA_OPENSSL_CONF + ) +where import Startlude @@ -258,52 +268,55 @@ OU = Embassy writeRootCaCert :: MonadIO m => FilePath -> FilePath -> FilePath -> m (ExitCode, String, String) writeRootCaCert confPath keyFilePath certFileDestinationPath = liftIO $ readProcessWithExitCode - "openssl" - [ "req" - , -- use x509 - "-new" - , -- new request - "-x509" - , -- self signed x509 - "-nodes" - , -- no passphrase - "-days" - , -- expires in... - "3650" - , -- valid for 10 years. Max is 20 years - "-key" - , -- source private key - toS keyFilePath - , "-out" + "openssl" + [ "req" + , -- use x509 + "-new" + , -- new request + "-x509" + , -- self signed x509 + "-nodes" + , -- no passphrase + "-days" + , -- expires in... + "3650" + , -- valid for 10 years. Max is 20 years + "-key" + , -- source private key + toS keyFilePath + , "-out" -- target cert path - , toS certFileDestinationPath - , "-config" + , toS certFileDestinationPath + , "-config" -- configured by... - , toS confPath - ] - "" + , toS confPath + ] + "" data DeriveCertificate = DeriveCertificate - { applicantConfPath :: FilePath - , applicantKeyPath :: FilePath - , applicantCertPath :: FilePath - , signingConfPath :: FilePath - , signingKeyPath :: FilePath - , signingCertPath :: FilePath - , duration :: Integer - } + { applicantConfPath :: FilePath + , applicantKeyPath :: FilePath + , applicantCertPath :: FilePath + , signingConfPath :: FilePath + , signingKeyPath :: FilePath + , signingCertPath :: FilePath + , duration :: Integer + } writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String) -writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do +writeIntermediateCert DeriveCertificate {..} = liftIO $ fromSys $ interpret $ do + lift . lift $ time "Intermediate Cert Write Start" -- openssl genrsa -out dump/int.key 4096 - segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] - -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr - segment $ openssl [i|req -new + segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] + lift . lift $ time "Generate intermediate RSA Key" + -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr + segment $ openssl [i|req -new -config #{applicantConfPath} -key #{applicantKeyPath} -nodes -out #{applicantCertPath <> ".csr"}|] - -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt - segment $ openssl [i|ca -batch + lift . lift $ time "Generate intermediate CSR" + -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt + segment $ openssl [i|ca -batch -config #{signingConfPath} -rand_serial -keyfile #{signingKeyPath} @@ -313,17 +326,22 @@ writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do -notext -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath}|] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + lift . lift $ time "Sign intermediate certificate" + liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + lift . lift $ time "Update certificate chain" writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String) -writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do - segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] - segment $ openssl [i|req -config #{applicantConfPath} +writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ fromSys $ interpret $ do + lift . lift $ time "Leaf Cert Write Start" + segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] + lift . lift $ time "Generate leaf RSA Key" + segment $ openssl [i|req -config #{applicantConfPath} -key #{applicantKeyPath} -new -addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress} -out #{applicantCertPath <> ".csr"}|] - segment $ openssl [i|ca -batch + lift . lift $ time "Generate leaf CSR" + segment $ openssl [i|ca -batch -config #{signingConfPath} -rand_serial -keyfile #{signingKeyPath} @@ -334,13 +352,15 @@ writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath} |] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + lift . lift $ time "Sign leaf CSR" + liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + lift . lift $ time "Update certificate chain" -openssl :: Text -> IO (ExitCode, String, String) -openssl = ($ "") . readProcessWithExitCode "openssl" . fmap toS . words +openssl :: MonadIO m => Text -> m (ExitCode, String, String) +openssl = liftIO . ($ "") . readProcessWithExitCode "openssl" . fmap toS . words {-# INLINE openssl #-} -interpret :: ExceptT ExitCode (StateT (String, String) IO) () -> IO (ExitCode, String, String) +interpret :: MonadIO m => ExceptT ExitCode (StateT (String, String) m) () -> m (ExitCode, String, String) interpret = fmap (over _1 (either id (const ExitSuccess)) . regroup) . flip runStateT ("", "") . runExceptT {-# INLINE interpret #-} @@ -348,8 +368,19 @@ regroup :: (a, (b, c)) -> (a, b, c) regroup (a, (b, c)) = (a, b, c) {-# INLINE regroup #-} -segment :: IO (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) IO) () -segment action = liftIO action >>= \case - (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) - (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec +segment :: MonadIO m => m (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) m) () +segment action = (lift . lift) action >>= \case + (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) + (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec {-# INLINE segment #-} + +time :: MonadIO m => Text -> StateT UTCTime m () +time t = do + last <- Startlude.get + now <- liftIO getCurrentTime + putStrLn @Text [i|#{t}: #{diffUTCTime now last}|] + put now + +fromSys :: MonadIO m => StateT UTCTime m a -> m a +fromSys m = liftIO getCurrentTime >>= evalStateT m + From 02552eb2784422ff993ec41c0377c496b6b97e60 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 27 Nov 2020 15:21:37 -0700 Subject: [PATCH 02/11] attempt to use P256 instead --- agent/src/Lib/Ssl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index 94e5f82bb..c8e5700b0 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -306,7 +306,7 @@ writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, writeIntermediateCert DeriveCertificate {..} = liftIO $ fromSys $ interpret $ do lift . lift $ time "Intermediate Cert Write Start" -- openssl genrsa -out dump/int.key 4096 - segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] + segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] lift . lift $ time "Generate intermediate RSA Key" -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr segment $ openssl [i|req -new @@ -333,7 +333,7 @@ writeIntermediateCert DeriveCertificate {..} = liftIO $ fromSys $ interpret $ do writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String) writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ fromSys $ interpret $ do lift . lift $ time "Leaf Cert Write Start" - segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|] + segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] lift . lift $ time "Generate leaf RSA Key" segment $ openssl [i|req -config #{applicantConfPath} -key #{applicantKeyPath} From f1208f281ca6004d64673c8ae655cd40c87fefec Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 17:44:18 -0700 Subject: [PATCH 03/11] fixes ssl renewal, replaces rsa with ecdsa for derivative certs --- agent/src/Application.hs | 5 ++ agent/src/Daemon/SslRenew.hs | 77 ++++++++++++++++++++++++++++ agent/src/Handler/Register/Nginx.hs | 79 +++++++++++++++++++++++++++-- agent/src/Lib/Notifications.hs | 15 +++++- agent/src/Lib/Ssl.hs | 1 + agent/src/Lib/Synchronizers.hs | 59 +++++++++++++++++---- agent/src/Lib/SystemPaths.hs | 7 +-- 7 files changed, 223 insertions(+), 20 deletions(-) create mode 100644 agent/src/Daemon/SslRenew.hs diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 27326812e..01d24c2df 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -65,6 +65,7 @@ import Lib.WebServer import Model import Settings import Lib.Background +import qualified Daemon.SslRenew as SSLRenew appMain :: IO () appMain = do @@ -187,6 +188,10 @@ startupSequence foundation = do void . forkIO . forever $ forkIO (runReaderT AppNotifications.fetchAndSave foundation) >> threadDelay 5_000_000 withAgentVersionLog_ "App notifications refreshing" + withAgentVersionLog_ "Initializing SSL certificate renewal loop" + void . forkIO . forever $ forkIO $ SSLRenew.renewSslLeafCert foundation + withAgentVersionLog_ "SSL Renewal daemon started" + -- reloading avahi daemon -- DRAGONS! make sure this step happens AFTER system synchronization withAgentVersionLog_ "Publishing Agent to Avahi Daemon" diff --git a/agent/src/Daemon/SslRenew.hs b/agent/src/Daemon/SslRenew.hs new file mode 100644 index 000000000..a0b47c97a --- /dev/null +++ b/agent/src/Daemon/SslRenew.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE QuasiQuotes #-} +module Daemon.SslRenew where + +import Startlude hiding ( err ) + +import Data.String.Interpolate ( i ) +import System.Process ( system ) + +import Foundation +import Lib.SystemPaths +import Settings +import Lib.Ssl +import Daemon.ZeroConf ( getStart9AgentHostname ) +import Lib.Tor +import Control.Carrier.Lift +import System.Directory ( renameDirectory + , removeDirectory + ) +import Lib.SystemCtl +import qualified Lib.Notifications as Notifications +import Database.Persist.Sql ( runSqlPool ) +import Lib.Types.Core +import Constants + +renewSslLeafCert :: AgentCtx -> IO () +renewSslLeafCert ctx = do + let base = appFilesystemBase . appSettings $ ctx + hn <- injectFilesystemBase base getStart9AgentHostname + tor <- injectFilesystemBase base getAgentHiddenServiceUrl + putStr @Text "SSL Renewal Required? " + needsRenew <- doesSslNeedRenew (toS $ entityCertPath hn `relativeTo` base) + print needsRenew + when needsRenew $ runM . injectFilesystemBase base $ do + 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) + + (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 -> + liftIO + . void + $ flip runSqlPool (appConnPool ctx) + $ Notifications.emit (AppId "EmbassyOS") agentVersion + $ Notifications.CertRenewFailed (ExitFailure n) out err + let sslDir = toS $ sslDirectory `relativeTo` base + liftIO $ removeDirectory sslDir + liftIO $ renameDirectory sslDirTmp sslDir + liftIO $ systemCtl RestartService "nginx" $> () + + +doesSslNeedRenew :: FilePath -> IO Bool +doesSslNeedRenew cert = do + ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|] + pure $ ec /= ExitSuccess diff --git a/agent/src/Handler/Register/Nginx.hs b/agent/src/Handler/Register/Nginx.hs index 2307c2740..8eff38c6d 100644 --- a/agent/src/Handler/Register/Nginx.hs +++ b/agent/src/Handler/Register/Nginx.hs @@ -5,6 +5,7 @@ module Handler.Register.Nginx where import Startlude hiding ( ask , catchError + , err ) import Control.Carrier.Error.Church @@ -23,6 +24,7 @@ import Lib.Tor import System.Posix ( removeLink ) import Data.String.Interpolate.IsString ( i ) +import Lib.SystemCtl time :: MonadIO m => Text -> StateT UTCTime m () time t = do @@ -67,13 +69,13 @@ resetSslState = do traverse_ (liftIO . removePathForcibly . toS . flip relativeTo base) [ rootCaKeyPath - , relBase $ (rootCaCertPath `relativeTo` "/") <> ".csr" + , relBase $ (rootCaCertPath `relativeTo` base) <> ".csr" , rootCaCertPath , intermediateCaKeyPath - , relBase $ (intermediateCaCertPath `relativeTo` "/") <> ".csr" + , relBase $ (intermediateCaCertPath `relativeTo` base) <> ".csr" , intermediateCaCertPath , entityKeyPath host - , relBase $ (entityCertPath host `relativeTo` "/") <> ".csr" + , relBase $ (entityCertPath host `relativeTo` base) <> ".csr" , entityCertPath host , entityConfPath host , nginxSitesAvailable nginxSslConf @@ -90,7 +92,6 @@ resetSslState = do _ <- liftIO $ try @SomeException . removeLink . toS $ nginxSitesEnabled nginxSslConf `relativeTo` base pure () - bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m () bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf" @@ -172,3 +173,73 @@ writeSslKeyAndCert rsaKeyFileContents = fromSys $ 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" $> () diff --git a/agent/src/Lib/Notifications.hs b/agent/src/Lib/Notifications.hs index 7e826e1cd..8da2e63ee 100644 --- a/agent/src/Lib/Notifications.hs +++ b/agent/src/Lib/Notifications.hs @@ -19,8 +19,8 @@ emit :: MonadIO m => AppId -> Version -> AgentNotification -> SqlPersistT m (Ent emit appId version ty = do uuid <- liftIO nextRandom now <- liftIO getCurrentTime - let k = (NotificationKey uuid) - let v = (Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty)) + let k = NotificationKey uuid + let v = Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty) insertKey k v putStrLn $ toMessage appId version ty pure $ Entity k v @@ -42,6 +42,7 @@ data AgentNotification = | RestoreFailed S9Error | RestartFailed S9Error | DockerFuckening + | CertRenewFailed ExitCode String String -- CODES -- RULES: @@ -54,6 +55,7 @@ data AgentNotification = -- The second digit indicates where the error was originated from as follows -- 0: Originates from Agent -- 1: Originates from App (Not presently used) +-- 2: Originates from Agent ABOUT THE AGENT -- -- The remaining section of the code may be as long as you want but must be at least one digit -- EXAMPLES: @@ -78,6 +80,7 @@ toCode (InstallFailedS9Error _) = "303" toCode (BackupFailed _) = "304" toCode (RestoreFailed _) = "305" toCode (RestartFailed _) = "306" +toCode CertRenewFailed{} = "320" toTitle :: AgentNotification -> Text toTitle InstallSuccess = "Install succeeded" @@ -90,6 +93,7 @@ toTitle (BackupFailed _) = "Backup failed" toTitle (RestoreFailed _) = "Restore failed" toTitle (RestartFailed _) = "Restart failed" toTitle DockerFuckening = "App unstoppable" +toTitle CertRenewFailed{} = "Embassy Certificate Renewal Failed" toMessage :: AppId -> Version -> AgentNotification -> Text toMessage appId version InstallSuccess = [i|Successfully installed #{appId} at version #{version}|] @@ -107,3 +111,10 @@ toMessage appId _version (BackupFailed reason) = [i|Failed to back up #{appId}: toMessage appId _version (RestoreFailed reason) = [i|Failed to restore #{appId}: #{errorMessage $ toError reason}|] toMessage appId _version (RestartFailed reason) = [i|Failed to restart #{appId}: #{errorMessage $ toError reason}. Please manually restart|] +toMessage _ version (CertRenewFailed ec o e) = [i|Failed to renew SSL Certificates for EmbassyOS (#{version}) +ExitCode: #{ec} +Stdout: +#{o} +Stderr: +#{e} +|] diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index c8e5700b0..14f232dbc 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -9,6 +9,7 @@ module Lib.Ssl , writeLeafCert , root_CA_OPENSSL_CONF , intermediate_CA_OPENSSL_CONF + , segment ) where diff --git a/agent/src/Lib/Synchronizers.hs b/agent/src/Lib/Synchronizers.hs index ae60630a2..6d1ba7240 100644 --- a/agent/src/Lib/Synchronizers.hs +++ b/agent/src/Lib/Synchronizers.hs @@ -87,7 +87,7 @@ parseKernelVersion = do major' <- decimal minor' <- char '.' *> decimal patch' <- char '.' *> decimal - arch <- string "-v7l+" *> pure ArmV7 <|> string "-v8+" *> pure ArmV8 + arch <- string "-v7l+" $> ArmV7 <|> string "-v8+" $> ArmV8 pure $ KernelVersion (Version (major', minor', patch', 0)) arch synchronizer :: Synchronizer @@ -141,7 +141,7 @@ syncCreateSshDir = SyncOp "Create SSH directory" check migrate False syncRemoveAvahiSystemdDependency :: SyncOp syncRemoveAvahiSystemdDependency = SyncOp "Remove Avahi Systemd Dependency" check migrate False where - wanted = decodeUtf8 $ $(embedFile "config/agent.service") + wanted = decodeUtf8 $(embedFile "config/agent.service") check = do base <- asks $ appFilesystemBase . appSettings content <- liftIO $ readFile (toS $ agentServicePath `relativeTo` base) @@ -172,7 +172,7 @@ sync32BitKernel = SyncOp "32 Bit Kernel Switch" check migrate True check = do settings <- asks appSettings cfg <- injectFilesystemBaseFromContext settings getBootCfgPath - liftIO . run $ fmap isNothing $ (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await) + liftIO . run $ isNothing <$> (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await) migrate = do base <- asks $ appFilesystemBase . appSettings let tmpFile = bootConfigTempPath `relativeTo` base @@ -234,9 +234,9 @@ syncWriteConf name contents' confLocation = SyncOp [i|Write #{name} Conf|] check liftIO $ (Just <$> readFile (toS $ confLocation `relativeTo` base)) `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - case conf of - Nothing -> pure True - Just co -> pure $ if co == contents then False else True + pure $ case conf of + Nothing -> True + Just co -> co /= contents migrate = do base <- asks $ appFilesystemBase . appSettings void . liftIO $ createDirectoryIfMissing True (takeDirectory (toS $ confLocation `relativeTo` base)) @@ -330,7 +330,7 @@ syncInstallAmbassadorUI = SyncOp "Install Ambassador UI" check migrate False streamUntar root stream = Conduit.runConduit $ Conduit.fromBStream stream .| Conduit.untar \f -> do let path = toS . (toS root ) . joinPath . drop 1 . splitPath . B8.unpack . Conduit.filePath $ f print path - if (Conduit.fileType f == Conduit.FTDirectory) + if Conduit.fileType f == Conduit.FTDirectory then liftIO $ createDirectoryIfMissing True path else Conduit.sinkFile path @@ -372,8 +372,8 @@ installAmbassadorUiNginx mSslOverrides fileName = do void . liftIO $ systemCtl RestartService "nginx" where ambassadorUiClientManifiest b = toS $ (ambassadorUiPath <> "/client-manifest.yaml") `relativeTo` b - nginxAvailableConf b = toS $ (nginxSitesAvailable fileName) `relativeTo` b - nginxEnabledConf b = toS $ (nginxSitesEnabled fileName) `relativeTo` b + nginxAvailableConf b = toS $ nginxSitesAvailable fileName `relativeTo` b + nginxEnabledConf b = toS $ nginxSitesEnabled fileName `relativeTo` b syncOpenHttpPorts :: SyncOp syncOpenHttpPorts = SyncOp "Open Hidden Service Port 80" check migrate False @@ -426,6 +426,47 @@ syncPersistLogs :: SyncOp syncPersistLogs = (syncWriteConf "Journald" $(embedFile "config/journald.conf") journaldConfig) { syncOpRequiresReboot = True } +syncRepairSsl :: SyncOp +syncRepairSsl = SyncOp "Repair SSL Certs" check migrate False + where + check = do + base <- asks $ appFilesystemBase . appSettings + let p = toS $ sslDirectory `relativeTo` base + liftIO $ not <$> doesDirectoryExist p + migrate = do + base <- asks $ appFilesystemBase . appSettings + let newCerts = toS $ (agentTmpDirectory <> sslDirectory) `relativeTo` base + liftIO $ renameDirectory newCerts (toS $ sslDirectory `relativeTo` base) + liftIO $ systemCtl RestartService "nginx" $> () + +-- 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 + +-- syncConvertEcdsaLeafCert :: SyncOp +-- syncConvertEcdsaLeafCert = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False +-- where +-- check = do +-- fs <- asks $ appFilesystemBase . appSettings +-- h <- injectFilesystemBase fs getStart9AgentHostname +-- header <- liftIO $ headMay . lines <$> readFile (toS $ entityKeyPath h `relativeTo` fs) +-- pure $ case header of +-- Nothing -> False +-- Just y -> "BEGIN RSA PRIVATE" `T.isInfixOf` y +-- migrate = do +-- base <- asks $ appFilesystemBase . appSettings +-- _ + +-- syncRotateExpiringCerts :: SyncOp +-- syncRotateExpiringCerts = _ + failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) () failUpdate e = do ref <- asks appIsUpdateFailed diff --git a/agent/src/Lib/SystemPaths.hs b/agent/src/Lib/SystemPaths.hs index d63da47ee..bbb4abb71 100644 --- a/agent/src/Lib/SystemPaths.hs +++ b/agent/src/Lib/SystemPaths.hs @@ -76,18 +76,15 @@ getAbsoluteLocationFor path = do readSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m (Maybe Text) readSystemPath path = do loadPath <- getAbsoluteLocationFor path - contents <- - liftIO + liftIO $ (Just <$> readFile (toS loadPath)) `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - pure contents -- like the above, but throws IO error if file not found readSystemPath' :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m Text readSystemPath' path = do loadPath <- getAbsoluteLocationFor path - contents <- liftIO . readFile . toS $ loadPath - pure contents + liftIO . readFile . toS $ loadPath writeSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> Text -> m () writeSystemPath path contents = do From d31b940c50f6cbdcd714b5155946390d7c20ba51 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 20:22:25 -0700 Subject: [PATCH 04/11] sleep before looping --- agent/src/Application.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 01d24c2df..898d11951 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -19,6 +19,7 @@ module Application , handler , runDb , getAgentCtx + , sleep ) where @@ -189,7 +190,7 @@ startupSequence foundation = do withAgentVersionLog_ "App notifications refreshing" withAgentVersionLog_ "Initializing SSL certificate renewal loop" - void . forkIO . forever $ forkIO $ SSLRenew.renewSslLeafCert foundation + void . forkIO . forever $ forkIO $ SSLRenew.renewSslLeafCert foundation *> sleep 86_400 withAgentVersionLog_ "SSL Renewal daemon started" -- reloading avahi daemon @@ -204,6 +205,10 @@ startupSequence foundation = do withAgentVersionLog_ "Listening for Self-Update Signal" waitForUpdateSignal foundation +sleep :: Integer -> IO () +sleep n = let (full, r) = (n * 1_000_000) `divMod` (fromIntegral $ (maxBound :: Int)) in + replicateM_ (fromIntegral full) (threadDelay maxBound) *> threadDelay (fromIntegral r) + -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the AgentCtx from GHCi) -------------------------------------------------------------- From 282675d1f839d7af708b6ce1fdd7ad386f465f35 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 20:51:26 -0700 Subject: [PATCH 05/11] fixes parenthesis --- agent/src/Application.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 898d11951..e13488b46 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -190,7 +190,7 @@ startupSequence foundation = do withAgentVersionLog_ "App notifications refreshing" withAgentVersionLog_ "Initializing SSL certificate renewal loop" - void . forkIO . forever $ forkIO $ SSLRenew.renewSslLeafCert foundation *> sleep 86_400 + void . forkIO . forever $ forkIO (SSLRenew.renewSslLeafCert foundation) *> sleep 86_400 withAgentVersionLog_ "SSL Renewal daemon started" -- reloading avahi daemon From bb6e09b5c25757273ac2ab54143f0fae4c362c2d Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 21:09:20 -0700 Subject: [PATCH 06/11] 0.2.6 --- agent/config/settings.yml | 2 +- agent/migrations/0.2.5::0.2.6 | 1 + agent/package.yaml | 2 +- agent/src/Lib/Synchronizers.hs | 8 ++++---- 4 files changed, 7 insertions(+), 6 deletions(-) create mode 100644 agent/migrations/0.2.5::0.2.6 diff --git a/agent/config/settings.yml b/agent/config/settings.yml index e86956673..1af22f3de 100644 --- a/agent/config/settings.yml +++ b/agent/config/settings.yml @@ -34,6 +34,6 @@ database: database: "start9_agent.sqlite3" poolsize: "_env:YESOD_SQLITE_POOLSIZE:10" -app-mgr-version-spec: "=0.2.5" +app-mgr-version-spec: "=0.2.6" #analytics: UA-YOURCODE diff --git a/agent/migrations/0.2.5::0.2.6 b/agent/migrations/0.2.5::0.2.6 new file mode 100644 index 000000000..b928005e2 --- /dev/null +++ b/agent/migrations/0.2.5::0.2.6 @@ -0,0 +1 @@ +SELECT TRUE; \ No newline at end of file diff --git a/agent/package.yaml b/agent/package.yaml index 5d4df9213..ee7c00ab2 100644 --- a/agent/package.yaml +++ b/agent/package.yaml @@ -1,5 +1,5 @@ name: ambassador-agent -version: 0.2.5 +version: 0.2.6 default-extensions: - NoImplicitPrelude diff --git a/agent/src/Lib/Synchronizers.hs b/agent/src/Lib/Synchronizers.hs index 6d1ba7240..e526ca75e 100644 --- a/agent/src/Lib/Synchronizers.hs +++ b/agent/src/Lib/Synchronizers.hs @@ -91,12 +91,12 @@ parseKernelVersion = do pure $ KernelVersion (Version (major', minor', patch', 0)) arch synchronizer :: Synchronizer -synchronizer = sync_0_2_5 +synchronizer = sync_0_2_6 {-# INLINE synchronizer #-} -sync_0_2_5 :: Synchronizer -sync_0_2_5 = Synchronizer - "0.2.5" +sync_0_2_6 :: Synchronizer +sync_0_2_6 = Synchronizer + "0.2.6" [ syncCreateAgentTmp , syncCreateSshDir , syncRemoveAvahiSystemdDependency From 5fa2c563cc516b6bfca0d9cd4fd7366931732199 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 21:59:36 -0700 Subject: [PATCH 07/11] removes timing code --- agent/src/Handler/Register.hs | 40 ++++++++++------------------- agent/src/Handler/Register/Nginx.hs | 18 +------------ 2 files changed, 14 insertions(+), 44 deletions(-) diff --git a/agent/src/Handler/Register.hs b/agent/src/Handler/Register.hs index f40bec097..e0cf59568 100644 --- a/agent/src/Handler/Register.hs +++ b/agent/src/Handler/Register.hs @@ -34,57 +34,43 @@ import Settings postRegisterR :: Handler RegisterRes -postRegisterR = handleS9ErrT . fromSys $ do - time "Start" - settings <- getsYesod appSettings +postRegisterR = handleS9ErrT $ do + settings <- getsYesod appSettings - productKey <- liftIO . getProductKey . appFilesystemBase $ settings - time "Read Product Key" - req <- requireCheckJsonBody - time "Parse JSON Body" + productKey <- liftIO . getProductKey . appFilesystemBase $ settings + req <- requireCheckJsonBody -- Decrypt torkey and password. This acts as product key authentication. - torKeyFileContents <- lift $ decryptTorkey productKey req - time "Decrypt Tor Key" - password <- lift $ decryptPassword productKey req - time "Decrypt Password" - rsaKeyFileContents <- lift $ decryptRSAKey productKey req - time "Decrypto RSA" + torKeyFileContents <- decryptTorkey productKey req + password <- decryptPassword productKey req + rsaKeyFileContents <- decryptRSAKey productKey req -- Check for existing registration. - lift $ checkExistingPasswordRegistration rootAccountName >>= \case + checkExistingPasswordRegistration rootAccountName >>= \case Nothing -> pure () Just _ -> sendResponseStatus (Status 209 "Preexisting") () - time "Check Password Registration" -- install new tor hidden service key and restart tor - registerResTorAddress <- - lift $ runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case - Just t -> pure t - Nothing -> throwE TorServiceTimeoutE - time "Bootstrap Tor Hidden Service" + registerResTorAddress <- runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case + Just t -> pure t + Nothing -> throwE TorServiceTimeoutE -- install new ssl CA cert + nginx conf and restart nginx registerResCert <- runM . handleS9ErrC . liftEither <=< liftIO . runM . injectFilesystemBaseFromContext settings $ do bootupHttpNginx runError @S9Error $ bootupSslNginx rsaKeyFileContents - time "Bootstrap SSL Configuration" -- create an hmac of the torAddress + caCert for front end registerResTorAddressSig <- produceProofOfKey productKey registerResTorAddress - time "Sign Tor Address" - registerResCertSig <- produceProofOfKey productKey registerResCert - time "Sign Certificate" + registerResCertSig <- produceProofOfKey productKey registerResCert -- must match CN in config/csr.conf let registerResCertName = root_CA_CERT_NAME registerResLanAddress <- runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostnameLocal - time "Fetch Agent Hostname" -- registration successful, save the password hash - registerResClaimedAt <- lift $ saveAccountRegistration rootAccountName password - time "Save Account Registration" + registerResClaimedAt <- saveAccountRegistration rootAccountName password pure RegisterRes { .. } diff --git a/agent/src/Handler/Register/Nginx.hs b/agent/src/Handler/Register/Nginx.hs index 8eff38c6d..bc42bba91 100644 --- a/agent/src/Handler/Register/Nginx.hs +++ b/agent/src/Handler/Register/Nginx.hs @@ -22,21 +22,8 @@ import Lib.Synchronizers import Lib.SystemPaths import Lib.Tor import System.Posix ( removeLink ) -import Data.String.Interpolate.IsString - ( i ) import Lib.SystemCtl -time :: MonadIO m => Text -> StateT UTCTime m () -time t = do - last <- Startlude.get - now <- liftIO getCurrentTime - putStrLn @Text [i|#{t}: #{diffUTCTime now last}|] - put now - -fromSys :: MonadIO m => StateT UTCTime m a -> m a -fromSys m = liftIO getCurrentTime >>= evalStateT m - - -- Left error, Right CA cert for hmac signing bootupSslNginx :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, Has (Lift IO) sig m, MonadIO m) => ByteString @@ -96,7 +83,7 @@ bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m () bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf" writeSslKeyAndCert :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => ByteString -> m Text -writeSslKeyAndCert rsaKeyFileContents = fromSys $ do +writeSslKeyAndCert rsaKeyFileContents = do directory <- toS <$> getAbsoluteLocationFor sslDirectory caKeyPath <- toS <$> getAbsoluteLocationFor rootCaKeyPath caConfPath <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath @@ -112,13 +99,10 @@ writeSslKeyAndCert rsaKeyFileContents = fromSys $ do let hostname = sid <> ".local" - time "SSL Start" liftIO $ createDirectoryIfMissing False directory liftIO $ BS.writeFile caKeyPath rsaKeyFileContents - time "Write SSL Root Key" (exit, str1, str2) <- writeRootCaCert caConfPath caKeyPath caCertPath - time "Generate SSL Root Cert" liftIO $ do putStrLn @Text "openssl logs" putStrLn @Text "exit code: " From 4f1eb69378ead18f4a9325411e1fd6ae72d94528 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 22:08:45 -0700 Subject: [PATCH 08/11] removes more timing calls --- agent/src/Lib/Ssl.hs | 25 ++----------------------- 1 file changed, 2 insertions(+), 23 deletions(-) diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index 14f232dbc..70e76f48c 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -304,18 +304,15 @@ data DeriveCertificate = DeriveCertificate , duration :: Integer } writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String) -writeIntermediateCert DeriveCertificate {..} = liftIO $ fromSys $ interpret $ do - lift . lift $ time "Intermediate Cert Write Start" +writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do -- openssl genrsa -out dump/int.key 4096 segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - lift . lift $ time "Generate intermediate RSA Key" -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr segment $ openssl [i|req -new -config #{applicantConfPath} -key #{applicantKeyPath} -nodes -out #{applicantCertPath <> ".csr"}|] - lift . lift $ time "Generate intermediate CSR" -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt segment $ openssl [i|ca -batch -config #{signingConfPath} @@ -327,21 +324,16 @@ writeIntermediateCert DeriveCertificate {..} = liftIO $ fromSys $ interpret $ do -notext -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath}|] - lift . lift $ time "Sign intermediate certificate" liftIO $ readFile signingCertPath >>= appendFile applicantCertPath - lift . lift $ time "Update certificate chain" writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String) -writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ fromSys $ interpret $ do - lift . lift $ time "Leaf Cert Write Start" +writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - lift . lift $ time "Generate leaf RSA Key" segment $ openssl [i|req -config #{applicantConfPath} -key #{applicantKeyPath} -new -addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress} -out #{applicantCertPath <> ".csr"}|] - lift . lift $ time "Generate leaf CSR" segment $ openssl [i|ca -batch -config #{signingConfPath} -rand_serial @@ -353,9 +345,7 @@ writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ fromSys $ in -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath} |] - lift . lift $ time "Sign leaf CSR" liftIO $ readFile signingCertPath >>= appendFile applicantCertPath - lift . lift $ time "Update certificate chain" openssl :: MonadIO m => Text -> m (ExitCode, String, String) openssl = liftIO . ($ "") . readProcessWithExitCode "openssl" . fmap toS . words @@ -374,14 +364,3 @@ segment action = (lift . lift) action >>= \case (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec {-# INLINE segment #-} - -time :: MonadIO m => Text -> StateT UTCTime m () -time t = do - last <- Startlude.get - now <- liftIO getCurrentTime - putStrLn @Text [i|#{t}: #{diffUTCTime now last}|] - put now - -fromSys :: MonadIO m => StateT UTCTime m a -> m a -fromSys m = liftIO getCurrentTime >>= evalStateT m - From 462cace44980691ad80973e2f187c961fd5bc359 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 22:13:36 -0700 Subject: [PATCH 09/11] uncomments rsa replacement synchronizer, removes unused code --- agent/src/Lib/Synchronizers.hs | 39 +++++++++++----------------------- 1 file changed, 12 insertions(+), 27 deletions(-) diff --git a/agent/src/Lib/Synchronizers.hs b/agent/src/Lib/Synchronizers.hs index e526ca75e..7dfb6dbe0 100644 --- a/agent/src/Lib/Synchronizers.hs +++ b/agent/src/Lib/Synchronizers.hs @@ -61,6 +61,8 @@ import Settings 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 ) data Synchronizer = Synchronizer @@ -439,33 +441,16 @@ syncRepairSsl = SyncOp "Repair SSL Certs" check migrate False liftIO $ renameDirectory newCerts (toS $ sslDirectory `relativeTo` base) liftIO $ systemCtl RestartService "nginx" $> () --- 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 - --- syncConvertEcdsaLeafCert :: SyncOp --- syncConvertEcdsaLeafCert = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False --- where --- check = do --- fs <- asks $ appFilesystemBase . appSettings --- h <- injectFilesystemBase fs getStart9AgentHostname --- header <- liftIO $ headMay . lines <$> readFile (toS $ entityKeyPath h `relativeTo` fs) --- pure $ case header of --- Nothing -> False --- Just y -> "BEGIN RSA PRIVATE" `T.isInfixOf` y --- migrate = do --- base <- asks $ appFilesystemBase . appSettings --- _ - --- syncRotateExpiringCerts :: SyncOp --- syncRotateExpiringCerts = _ +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 failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) () failUpdate e = do From 24003a83977faf51ede512ec93ff35182cdfd4a7 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 22:14:52 -0700 Subject: [PATCH 10/11] revert spurious spacing change --- agent/src/Lib/Ssl.hs | 104 +++++++++++++++++++++---------------------- 1 file changed, 52 insertions(+), 52 deletions(-) diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index 70e76f48c..2bec299e6 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -1,16 +1,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} module Lib.Ssl - ( DeriveCertificate(..) - , root_CA_CERT_NAME - , writeRootCaCert - , writeIntermediateCert - , domain_CSR_CONF - , writeLeafCert - , root_CA_OPENSSL_CONF - , intermediate_CA_OPENSSL_CONF - , segment - ) + ( DeriveCertificate(..) + , root_CA_CERT_NAME + , writeRootCaCert + , writeIntermediateCert + , domain_CSR_CONF + , writeLeafCert + , root_CA_OPENSSL_CONF + , intermediate_CA_OPENSSL_CONF + , segment + ) where import Startlude @@ -269,52 +269,52 @@ OU = Embassy writeRootCaCert :: MonadIO m => FilePath -> FilePath -> FilePath -> m (ExitCode, String, String) writeRootCaCert confPath keyFilePath certFileDestinationPath = liftIO $ readProcessWithExitCode - "openssl" - [ "req" - , -- use x509 - "-new" - , -- new request - "-x509" - , -- self signed x509 - "-nodes" - , -- no passphrase - "-days" - , -- expires in... - "3650" - , -- valid for 10 years. Max is 20 years - "-key" - , -- source private key - toS keyFilePath - , "-out" + "openssl" + [ "req" + , -- use x509 + "-new" + , -- new request + "-x509" + , -- self signed x509 + "-nodes" + , -- no passphrase + "-days" + , -- expires in... + "3650" + , -- valid for 10 years. Max is 20 years + "-key" + , -- source private key + toS keyFilePath + , "-out" -- target cert path - , toS certFileDestinationPath - , "-config" + , toS certFileDestinationPath + , "-config" -- configured by... - , toS confPath - ] - "" + , toS confPath + ] + "" data DeriveCertificate = DeriveCertificate - { applicantConfPath :: FilePath - , applicantKeyPath :: FilePath - , applicantCertPath :: FilePath - , signingConfPath :: FilePath - , signingKeyPath :: FilePath - , signingCertPath :: FilePath - , duration :: Integer - } + { applicantConfPath :: FilePath + , applicantKeyPath :: FilePath + , applicantCertPath :: FilePath + , signingConfPath :: FilePath + , signingKeyPath :: FilePath + , signingCertPath :: FilePath + , duration :: Integer + } writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String) writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do -- openssl genrsa -out dump/int.key 4096 - segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr - segment $ openssl [i|req -new + segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] + -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr + segment $ openssl [i|req -new -config #{applicantConfPath} -key #{applicantKeyPath} -nodes -out #{applicantCertPath <> ".csr"}|] - -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt - segment $ openssl [i|ca -batch + -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt + segment $ openssl [i|ca -batch -config #{signingConfPath} -rand_serial -keyfile #{signingKeyPath} @@ -324,17 +324,17 @@ writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do -notext -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath}|] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + liftIO $ readFile signingCertPath >>= appendFile applicantCertPath writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String) writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do - segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - segment $ openssl [i|req -config #{applicantConfPath} + segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] + segment $ openssl [i|req -config #{applicantConfPath} -key #{applicantKeyPath} -new -addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress} -out #{applicantCertPath <> ".csr"}|] - segment $ openssl [i|ca -batch + segment $ openssl [i|ca -batch -config #{signingConfPath} -rand_serial -keyfile #{signingKeyPath} @@ -345,7 +345,7 @@ writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ -in #{applicantCertPath <> ".csr"} -out #{applicantCertPath} |] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath + liftIO $ readFile signingCertPath >>= appendFile applicantCertPath openssl :: MonadIO m => Text -> m (ExitCode, String, String) openssl = liftIO . ($ "") . readProcessWithExitCode "openssl" . fmap toS . words @@ -361,6 +361,6 @@ regroup (a, (b, c)) = (a, b, c) segment :: MonadIO m => m (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) m) () segment action = (lift . lift) action >>= \case - (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) - (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec + (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) + (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec {-# INLINE segment #-} From 8288679bf62d80640365bb8808b668f62d360485 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 30 Nov 2020 22:16:56 -0700 Subject: [PATCH 11/11] Update agent/src/Handler/Register.hs --- agent/src/Handler/Register.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/agent/src/Handler/Register.hs b/agent/src/Handler/Register.hs index e0cf59568..734d821dd 100644 --- a/agent/src/Handler/Register.hs +++ b/agent/src/Handler/Register.hs @@ -32,7 +32,6 @@ import Lib.SystemPaths import Model import Settings - postRegisterR :: Handler RegisterRes postRegisterR = handleS9ErrT $ do settings <- getsYesod appSettings