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 +