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