adds timing instruments to see why setup takes so long

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

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
+postRegisterR :: Handler RegisterRes
-    req                <- requireCheckJsonBody
+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
+    torKeyFileContents <- lift $ decryptTorkey productKey req
-    password           <- decryptPassword productKey req
+    time "Decrypt Tor Key"
-    rsaKeyFileContents <- decryptRSAKey productKey req
+    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
+    registerResTorAddress <-
-        Just t  -> pure t
+        lift $ runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case
-        Nothing -> throwE TorServiceTimeoutE
+            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 { .. }
 
 

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

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"
+  "openssl"
-    [ "req"
+  [ "req"
-    , -- use x509
+  , -- use x509
-      "-new"
+    "-new"
-    , -- new request
+  , -- new request
-      "-x509"
+    "-x509"
-    , -- self signed x509
+  , -- self signed x509
-      "-nodes"
+    "-nodes"
-    , -- no passphrase
+  , -- no passphrase
-      "-days"
+    "-days"
-    , -- expires in...
+  , -- expires in...
-      "3650"
+    "3650"
-    , -- valid for 10 years. Max is 20 years
+  , -- valid for 10 years. Max is 20 years
-      "-key"
+    "-key"
-    , -- source private key
+  , -- source private key
-      toS keyFilePath
+    toS keyFilePath
-    , "-out"
+  , "-out"
     -- target cert path
-    , toS certFileDestinationPath
+  , toS certFileDestinationPath
-    , "-config"
+  , "-config"
       -- configured by...
-    , toS confPath
+  , toS confPath
-    ]
+  ]
-    ""
+  ""
 
 data DeriveCertificate = DeriveCertificate
-    { applicantConfPath :: FilePath
+  { applicantConfPath :: FilePath
-    , applicantKeyPath  :: FilePath
+  , applicantKeyPath  :: FilePath
-    , applicantCertPath :: FilePath
+  , applicantCertPath :: FilePath
-    , signingConfPath   :: FilePath
+  , signingConfPath   :: FilePath
-    , signingKeyPath    :: FilePath
+  , signingKeyPath    :: FilePath
-    , signingCertPath   :: FilePath
+  , signingCertPath   :: FilePath
-    , duration          :: Integer
+  , 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|]
+  segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
-    -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr
+  lift . lift $ time "Generate intermediate RSA Key"
-    segment $ openssl [i|req -new
+  -- 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
+  lift . lift $ time "Generate intermediate CSR"
-    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}
@@ -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
+writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ fromSys $ interpret $ do
-    segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
+  lift . lift $ time "Leaf Cert Write Start"
-    segment $ openssl [i|req -config #{applicantConfPath}
+  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 :: MonadIO m => Text -> m (ExitCode, String, String)
-openssl = ($ "") . readProcessWithExitCode "openssl" . fmap toS . words
+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 :: MonadIO m => m (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) m) ()
-segment action = liftIO action >>= \case
+segment action = (lift . lift) action >>= \case
-    (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e))
+  (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e))
-    (ec         , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec
+  (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
+