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

adds timing instruments to see why setup takes so long

Browse Source
This commit is contained in:
Keagan McClelland
2020-11-27 11:13:04 -07:00
parent ba9f545f44
commit b4b2ec6d99
4 changed files with 132 additions and 69 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
agent/src/Application.hs
View File

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

46
agent/src/Handler/Register.hs
View File

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

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

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

131
agent/src/Lib/Ssl.hs
View File

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