diff --git a/agent/src/Application.hs b/agent/src/Application.hs index 27326812e..01d24c2df 100644 --- a/agent/src/Application.hs +++ b/agent/src/Application.hs @@ -65,6 +65,7 @@ import Lib.WebServer import Model import Settings import Lib.Background +import qualified Daemon.SslRenew as SSLRenew appMain :: IO () appMain = do @@ -187,6 +188,10 @@ startupSequence foundation = do void . forkIO . forever $ forkIO (runReaderT AppNotifications.fetchAndSave foundation) >> threadDelay 5_000_000 withAgentVersionLog_ "App notifications refreshing" + withAgentVersionLog_ "Initializing SSL certificate renewal loop" + void . forkIO . forever $ forkIO $ SSLRenew.renewSslLeafCert foundation + withAgentVersionLog_ "SSL Renewal daemon started" + -- reloading avahi daemon -- DRAGONS! make sure this step happens AFTER system synchronization withAgentVersionLog_ "Publishing Agent to Avahi Daemon" diff --git a/agent/src/Daemon/SslRenew.hs b/agent/src/Daemon/SslRenew.hs new file mode 100644 index 000000000..a0b47c97a --- /dev/null +++ b/agent/src/Daemon/SslRenew.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE QuasiQuotes #-} +module Daemon.SslRenew where + +import Startlude hiding ( err ) + +import Data.String.Interpolate ( i ) +import System.Process ( system ) + +import Foundation +import Lib.SystemPaths +import Settings +import Lib.Ssl +import Daemon.ZeroConf ( getStart9AgentHostname ) +import Lib.Tor +import Control.Carrier.Lift +import System.Directory ( renameDirectory + , removeDirectory + ) +import Lib.SystemCtl +import qualified Lib.Notifications as Notifications +import Database.Persist.Sql ( runSqlPool ) +import Lib.Types.Core +import Constants + +renewSslLeafCert :: AgentCtx -> IO () +renewSslLeafCert ctx = do + let base = appFilesystemBase . appSettings $ ctx + hn <- injectFilesystemBase base getStart9AgentHostname + tor <- injectFilesystemBase base getAgentHiddenServiceUrl + putStr @Text "SSL Renewal Required? " + needsRenew <- doesSslNeedRenew (toS $ entityCertPath hn `relativeTo` base) + print needsRenew + when needsRenew $ runM . injectFilesystemBase base $ do + intCaKeyPath <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath + intCaConfPath <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath + intCaCertPath <- toS <$> getAbsoluteLocationFor intermediateCaCertPath + + sslDirTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> sslDirectory) + entKeyPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath hn) + entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath hn) + entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath hn) + + (ec, out, err) <- writeLeafCert + DeriveCertificate { applicantConfPath = entConfPathTmp + , applicantKeyPath = entKeyPathTmp + , applicantCertPath = entCertPathTmp + , signingConfPath = intCaConfPath + , signingKeyPath = intCaKeyPath + , signingCertPath = intCaCertPath + , duration = 365 + } + hn + tor + liftIO $ do + putStrLn @Text "openssl logs" + putStrLn @Text "exit code: " + print ec + putStrLn @String $ "stdout: " <> out + putStrLn @String $ "stderr: " <> err + case ec of + ExitSuccess -> pure () + ExitFailure n -> + liftIO + . void + $ flip runSqlPool (appConnPool ctx) + $ Notifications.emit (AppId "EmbassyOS") agentVersion + $ Notifications.CertRenewFailed (ExitFailure n) out err + let sslDir = toS $ sslDirectory `relativeTo` base + liftIO $ removeDirectory sslDir + liftIO $ renameDirectory sslDirTmp sslDir + liftIO $ systemCtl RestartService "nginx" $> () + + +doesSslNeedRenew :: FilePath -> IO Bool +doesSslNeedRenew cert = do + ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|] + pure $ ec /= ExitSuccess diff --git a/agent/src/Handler/Register/Nginx.hs b/agent/src/Handler/Register/Nginx.hs index 2307c2740..8eff38c6d 100644 --- a/agent/src/Handler/Register/Nginx.hs +++ b/agent/src/Handler/Register/Nginx.hs @@ -5,6 +5,7 @@ module Handler.Register.Nginx where import Startlude hiding ( ask , catchError + , err ) import Control.Carrier.Error.Church @@ -23,6 +24,7 @@ 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 @@ -67,13 +69,13 @@ resetSslState = do traverse_ (liftIO . removePathForcibly . toS . flip relativeTo base) [ rootCaKeyPath - , relBase $ (rootCaCertPath `relativeTo` "/") <> ".csr" + , relBase $ (rootCaCertPath `relativeTo` base) <> ".csr" , rootCaCertPath , intermediateCaKeyPath - , relBase $ (intermediateCaCertPath `relativeTo` "/") <> ".csr" + , relBase $ (intermediateCaCertPath `relativeTo` base) <> ".csr" , intermediateCaCertPath , entityKeyPath host - , relBase $ (entityCertPath host `relativeTo` "/") <> ".csr" + , relBase $ (entityCertPath host `relativeTo` base) <> ".csr" , entityCertPath host , entityConfPath host , nginxSitesAvailable nginxSslConf @@ -90,7 +92,6 @@ resetSslState = do _ <- liftIO $ try @SomeException . removeLink . toS $ nginxSitesEnabled nginxSslConf `relativeTo` base pure () - bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m () bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf" @@ -172,3 +173,73 @@ writeSslKeyAndCert rsaKeyFileContents = fromSys $ do ExitFailure ec -> throwError $ OpenSslE "leaf" ec str1' str2' readSystemPath' rootCaCertPath + +replaceDerivativeCerts :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, MonadIO m) => m () +replaceDerivativeCerts = do + hn <- getStart9AgentHostname + tor <- getAgentHiddenServiceUrl + + caKeyPath <- toS <$> getAbsoluteLocationFor rootCaKeyPath + caConfPath <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath + caCertPath <- toS <$> getAbsoluteLocationFor rootCaCertPath + + intCaKeyPath <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath + intCaConfPath <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath + intCaCertPath <- toS <$> getAbsoluteLocationFor intermediateCaCertPath + + sslDirTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> sslDirectory) + entKeyPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath hn) + entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath hn) + entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath hn) + liftIO $ createDirectoryIfMissing True sslDirTmp + liftIO $ BS.writeFile entConfPathTmp (domain_CSR_CONF hn) + + -- ensure duplicate certificates are acceptable + base <- Fused.ask @"filesystemBase" + liftIO $ BS.writeFile (toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) "unique_subject = no\n" + liftIO $ BS.writeFile (toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base) + "unique_subject = no\n" + + (ec, out, err) <- writeIntermediateCert DeriveCertificate { applicantConfPath = intCaConfPath + , applicantKeyPath = intCaKeyPath + , applicantCertPath = intCaCertPath + , signingConfPath = caConfPath + , signingKeyPath = caKeyPath + , signingCertPath = caCertPath + , duration = 3650 + } + liftIO $ do + putStrLn @Text "openssl logs" + putStrLn @Text "exit code: " + print ec + putStrLn @String $ "stdout: " <> out + putStrLn @String $ "stderr: " <> err + case ec of + ExitSuccess -> pure () + ExitFailure n -> throwError $ OpenSslE "leaf" n out err + + (ec', out', err') <- writeLeafCert + DeriveCertificate { applicantConfPath = entConfPathTmp + , applicantKeyPath = entKeyPathTmp + , applicantCertPath = entCertPathTmp + , signingConfPath = intCaConfPath + , signingKeyPath = intCaKeyPath + , signingCertPath = intCaCertPath + , duration = 365 + } + hn + tor + liftIO $ do + putStrLn @Text "openssl logs" + putStrLn @Text "exit code: " + print ec + putStrLn @String $ "stdout: " <> out' + putStrLn @String $ "stderr: " <> err' + case ec' of + ExitSuccess -> pure () + ExitFailure n -> throwError $ OpenSslE "leaf" n out' err' + + sslDir <- toS <$> getAbsoluteLocationFor sslDirectory + liftIO $ removeDirectory sslDir + liftIO $ renameDirectory sslDirTmp sslDir + liftIO $ systemCtl RestartService "nginx" $> () diff --git a/agent/src/Lib/Notifications.hs b/agent/src/Lib/Notifications.hs index 7e826e1cd..8da2e63ee 100644 --- a/agent/src/Lib/Notifications.hs +++ b/agent/src/Lib/Notifications.hs @@ -19,8 +19,8 @@ emit :: MonadIO m => AppId -> Version -> AgentNotification -> SqlPersistT m (Ent emit appId version ty = do uuid <- liftIO nextRandom now <- liftIO getCurrentTime - let k = (NotificationKey uuid) - let v = (Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty)) + let k = NotificationKey uuid + let v = Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty) insertKey k v putStrLn $ toMessage appId version ty pure $ Entity k v @@ -42,6 +42,7 @@ data AgentNotification = | RestoreFailed S9Error | RestartFailed S9Error | DockerFuckening + | CertRenewFailed ExitCode String String -- CODES -- RULES: @@ -54,6 +55,7 @@ data AgentNotification = -- The second digit indicates where the error was originated from as follows -- 0: Originates from Agent -- 1: Originates from App (Not presently used) +-- 2: Originates from Agent ABOUT THE AGENT -- -- The remaining section of the code may be as long as you want but must be at least one digit -- EXAMPLES: @@ -78,6 +80,7 @@ toCode (InstallFailedS9Error _) = "303" toCode (BackupFailed _) = "304" toCode (RestoreFailed _) = "305" toCode (RestartFailed _) = "306" +toCode CertRenewFailed{} = "320" toTitle :: AgentNotification -> Text toTitle InstallSuccess = "Install succeeded" @@ -90,6 +93,7 @@ toTitle (BackupFailed _) = "Backup failed" toTitle (RestoreFailed _) = "Restore failed" toTitle (RestartFailed _) = "Restart failed" toTitle DockerFuckening = "App unstoppable" +toTitle CertRenewFailed{} = "Embassy Certificate Renewal Failed" toMessage :: AppId -> Version -> AgentNotification -> Text toMessage appId version InstallSuccess = [i|Successfully installed #{appId} at version #{version}|] @@ -107,3 +111,10 @@ toMessage appId _version (BackupFailed reason) = [i|Failed to back up #{appId}: toMessage appId _version (RestoreFailed reason) = [i|Failed to restore #{appId}: #{errorMessage $ toError reason}|] toMessage appId _version (RestartFailed reason) = [i|Failed to restart #{appId}: #{errorMessage $ toError reason}. Please manually restart|] +toMessage _ version (CertRenewFailed ec o e) = [i|Failed to renew SSL Certificates for EmbassyOS (#{version}) +ExitCode: #{ec} +Stdout: +#{o} +Stderr: +#{e} +|] diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs index c8e5700b0..14f232dbc 100644 --- a/agent/src/Lib/Ssl.hs +++ b/agent/src/Lib/Ssl.hs @@ -9,6 +9,7 @@ module Lib.Ssl , writeLeafCert , root_CA_OPENSSL_CONF , intermediate_CA_OPENSSL_CONF + , segment ) where diff --git a/agent/src/Lib/Synchronizers.hs b/agent/src/Lib/Synchronizers.hs index ae60630a2..6d1ba7240 100644 --- a/agent/src/Lib/Synchronizers.hs +++ b/agent/src/Lib/Synchronizers.hs @@ -87,7 +87,7 @@ parseKernelVersion = do major' <- decimal minor' <- char '.' *> decimal patch' <- char '.' *> decimal - arch <- string "-v7l+" *> pure ArmV7 <|> string "-v8+" *> pure ArmV8 + arch <- string "-v7l+" $> ArmV7 <|> string "-v8+" $> ArmV8 pure $ KernelVersion (Version (major', minor', patch', 0)) arch synchronizer :: Synchronizer @@ -141,7 +141,7 @@ syncCreateSshDir = SyncOp "Create SSH directory" check migrate False syncRemoveAvahiSystemdDependency :: SyncOp syncRemoveAvahiSystemdDependency = SyncOp "Remove Avahi Systemd Dependency" check migrate False where - wanted = decodeUtf8 $ $(embedFile "config/agent.service") + wanted = decodeUtf8 $(embedFile "config/agent.service") check = do base <- asks $ appFilesystemBase . appSettings content <- liftIO $ readFile (toS $ agentServicePath `relativeTo` base) @@ -172,7 +172,7 @@ sync32BitKernel = SyncOp "32 Bit Kernel Switch" check migrate True check = do settings <- asks appSettings cfg <- injectFilesystemBaseFromContext settings getBootCfgPath - liftIO . run $ fmap isNothing $ (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await) + liftIO . run $ isNothing <$> (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await) migrate = do base <- asks $ appFilesystemBase . appSettings let tmpFile = bootConfigTempPath `relativeTo` base @@ -234,9 +234,9 @@ syncWriteConf name contents' confLocation = SyncOp [i|Write #{name} Conf|] check liftIO $ (Just <$> readFile (toS $ confLocation `relativeTo` base)) `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - case conf of - Nothing -> pure True - Just co -> pure $ if co == contents then False else True + pure $ case conf of + Nothing -> True + Just co -> co /= contents migrate = do base <- asks $ appFilesystemBase . appSettings void . liftIO $ createDirectoryIfMissing True (takeDirectory (toS $ confLocation `relativeTo` base)) @@ -330,7 +330,7 @@ syncInstallAmbassadorUI = SyncOp "Install Ambassador UI" check migrate False streamUntar root stream = Conduit.runConduit $ Conduit.fromBStream stream .| Conduit.untar \f -> do let path = toS . (toS root ) . joinPath . drop 1 . splitPath . B8.unpack . Conduit.filePath $ f print path - if (Conduit.fileType f == Conduit.FTDirectory) + if Conduit.fileType f == Conduit.FTDirectory then liftIO $ createDirectoryIfMissing True path else Conduit.sinkFile path @@ -372,8 +372,8 @@ installAmbassadorUiNginx mSslOverrides fileName = do void . liftIO $ systemCtl RestartService "nginx" where ambassadorUiClientManifiest b = toS $ (ambassadorUiPath <> "/client-manifest.yaml") `relativeTo` b - nginxAvailableConf b = toS $ (nginxSitesAvailable fileName) `relativeTo` b - nginxEnabledConf b = toS $ (nginxSitesEnabled fileName) `relativeTo` b + nginxAvailableConf b = toS $ nginxSitesAvailable fileName `relativeTo` b + nginxEnabledConf b = toS $ nginxSitesEnabled fileName `relativeTo` b syncOpenHttpPorts :: SyncOp syncOpenHttpPorts = SyncOp "Open Hidden Service Port 80" check migrate False @@ -426,6 +426,47 @@ syncPersistLogs :: SyncOp syncPersistLogs = (syncWriteConf "Journald" $(embedFile "config/journald.conf") journaldConfig) { syncOpRequiresReboot = True } +syncRepairSsl :: SyncOp +syncRepairSsl = SyncOp "Repair SSL Certs" check migrate False + where + check = do + base <- asks $ appFilesystemBase . appSettings + let p = toS $ sslDirectory `relativeTo` base + liftIO $ not <$> doesDirectoryExist p + migrate = do + base <- asks $ appFilesystemBase . appSettings + let newCerts = toS $ (agentTmpDirectory <> sslDirectory) `relativeTo` base + liftIO $ renameDirectory newCerts (toS $ sslDirectory `relativeTo` base) + liftIO $ systemCtl RestartService "nginx" $> () + +-- syncConvertEcdsaCerts :: SyncOp +-- syncConvertEcdsaCerts = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False +-- where +-- check = do +-- fs <- asks $ appFilesystemBase . appSettings +-- header <- liftIO $ headMay . lines <$> readFile (toS $ intermediateCaKeyPath `relativeTo` fs) +-- pure $ case header of +-- Nothing -> False +-- Just y -> "BEGIN RSA PRIVATE KEY" `T.isInfixOf` y +-- migrate = replaceDerivativeCerts + +-- syncConvertEcdsaLeafCert :: SyncOp +-- syncConvertEcdsaLeafCert = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False +-- where +-- check = do +-- fs <- asks $ appFilesystemBase . appSettings +-- h <- injectFilesystemBase fs getStart9AgentHostname +-- header <- liftIO $ headMay . lines <$> readFile (toS $ entityKeyPath h `relativeTo` fs) +-- pure $ case header of +-- Nothing -> False +-- Just y -> "BEGIN RSA PRIVATE" `T.isInfixOf` y +-- migrate = do +-- base <- asks $ appFilesystemBase . appSettings +-- _ + +-- syncRotateExpiringCerts :: SyncOp +-- syncRotateExpiringCerts = _ + failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) () failUpdate e = do ref <- asks appIsUpdateFailed diff --git a/agent/src/Lib/SystemPaths.hs b/agent/src/Lib/SystemPaths.hs index d63da47ee..bbb4abb71 100644 --- a/agent/src/Lib/SystemPaths.hs +++ b/agent/src/Lib/SystemPaths.hs @@ -76,18 +76,15 @@ getAbsoluteLocationFor path = do readSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m (Maybe Text) readSystemPath path = do loadPath <- getAbsoluteLocationFor path - contents <- - liftIO + liftIO $ (Just <$> readFile (toS loadPath)) `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - pure contents -- like the above, but throws IO error if file not found readSystemPath' :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m Text readSystemPath' path = do loadPath <- getAbsoluteLocationFor path - contents <- liftIO . readFile . toS $ loadPath - pure contents + liftIO . readFile . toS $ loadPath writeSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> Text -> m () writeSystemPath path contents = do