adds timing instruments to see why setup takes so long

2026-03-30 12:11:56 +00:00 · 2020-11-27 11:13:04 -07:00
parent ba9f545f44
commit b4b2ec6d99
4 changed files with 132 additions and 69 deletions
--- 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
+