periodically restarts tor daemon when it fails to get a response from itself, rate limits restarts

agent/package.yaml

@@ -42,6 +42,7 @@ dependencies:
 - comonad
 - conduit
 - conduit-extra
+- connection
 - containers
 - cryptonite
 - cryptonite-conduit
@@ -72,6 +73,7 @@ dependencies:
 - mime-types
 - monad-control
 - monad-logger
+- network
 - persistent
 - persistent-sqlite
 - persistent-template
@@ -82,6 +84,7 @@ dependencies:
 - regex-compat # TODO: trim this dep
 - shell-conduit
 - singletons
+- socks
 - stm
 - streaming
 - streaming-bytestring

agent/src/Application.hs

@@ -67,6 +67,8 @@ import           Model
 import           Settings
 import Lib.Background
 import qualified Daemon.SslRenew as SSLRenew
+import Lib.Tor (newTorManager)
+import Daemon.TorHealth
 
 appMain :: IO ()
 appMain = do
@@ -106,6 +108,7 @@ makeFoundation appSettings = do
     -- subsite.
     appLogger                   <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
     appHttpManager              <- getGlobalManager
+    appTorManager               <- newTorManager (appTorSocksPort appSettings)
     appWebServerThreadId        <- newIORef Nothing
     appSelfUpdateSpecification  <- newEmptyMVar
     appIsUpdating               <- newIORef Nothing
@@ -193,6 +196,10 @@ startupSequence foundation = do
         void . forkIO . forever $ forkIO (SSLRenew.renewSslLeafCert foundation) *> sleep 86_400
         withAgentVersionLog_ "SSL Renewal daemon started"
 
+        withAgentVersionLog_ "Initializing Tor health check loop"
+        void . forkIO . forever $ forkIO (runReaderT torHealth foundation) *> sleep 300
+        withAgentVersionLog_ "Tor health check loop running"
+
         -- reloading avahi daemon
         -- DRAGONS! make sure this step happens AFTER system synchronization
         withAgentVersionLog_ "Publishing Agent to Avahi Daemon"

agent/src/Daemon/TorHealth.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Daemon.TorHealth where
+
+import           Startlude
+
+import           Data.String.Interpolate.IsString
+
+import           Foundation
+import           Lib.SystemPaths
+import           Lib.Tor
+import           Yesod                          ( RenderRoute(renderRoute) )
+import           Network.HTTP.Simple            ( getResponseBody )
+import           Network.HTTP.Client            ( parseRequest )
+import           Network.HTTP.Client            ( httpLbs )
+import           Data.ByteString.Lazy           ( toStrict )
+import qualified UnliftIO.Exception            as UnliftIO
+import           Settings
+import           Data.IORef                     ( writeIORef
+                                                , readIORef
+                                                )
+import           Lib.SystemCtl
+
+torHealth :: ReaderT AgentCtx IO ()
+torHealth = do
+    settings <- asks appSettings
+    host     <- injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
+    let url = mappend [i|http://#{host}:5959|] . fold $ mappend "/" <$> fst (renderRoute VersionR)
+    response <- UnliftIO.try @_ @SomeException $ torGet (toS url)
+    case response of
+        Left _ -> do
+            putStrLn @Text "Failed Tor health check"
+            lastRestart <- asks appLastTorRestart >>= liftIO . readIORef
+            cooldown    <- asks $ appTorRestartCooldown . appSettings
+            now         <- liftIO getCurrentTime
+            if now > addUTCTime cooldown lastRestart
+                then do
+                    ec <- liftIO $ systemCtl RestartService "tor"
+                    case ec of
+                        ExitSuccess   -> asks appLastTorRestart >>= liftIO . flip writeIORef now
+                        ExitFailure _ -> do
+                            putStrLn @Text "Failed to restart tor daemon after failed tor health check"
+                else do
+                    putStrLn @Text "Failed tor healthcheck inside of cooldown window, tor will not be restarted"
+        Right _ -> pure ()
+
+torGet :: String -> ReaderT AgentCtx IO ByteString
+torGet url = do
+    manager <- asks appTorManager
+    req     <- parseRequest url
+    liftIO $ toStrict . getResponseBody <$> httpLbs req manager

agent/src/Foundation.hs

@@ -62,6 +62,7 @@ import           Settings
 data AgentCtx = AgentCtx
     { appSettings                 :: AppSettings
     , appHttpManager              :: Manager
+    , appTorManager               :: Manager
     , appConnPool                 :: ConnectionPool -- ^ Database connection pool.
     , appLogger                   :: Logger
     , appWebServerThreadId        :: IORef (Maybe ThreadId)
@@ -71,6 +72,7 @@ data AgentCtx = AgentCtx
     , appSelfUpdateSpecification  :: MVar VersionRange
     , appBackgroundJobs           :: TVar JobCache
     , appIconTags                 :: TVar (HM.HashMap AppId (Digest MD5))
+    , appLastTorRestart           :: IORef UTCTime
     }
 
 setWebProcessThreadId :: ThreadId -> AgentCtx -> IO ()

agent/src/Lib/Tor.hs

@@ -3,11 +3,22 @@ module Lib.Tor where
 import           Startlude
 
 import qualified Data.Text                     as T
+import           Network.HTTP.Client
+import           Network.Connection
 
 import           Lib.SystemPaths
+import           Network.HTTP.Client.TLS        ( mkManagerSettings
+                                                , newTlsManagerWith
+                                                )
+import           Data.Default
 
 getAgentHiddenServiceUrl :: (HasFilesystemBase sig m, MonadIO m) => m Text
 getAgentHiddenServiceUrl = T.strip <$> readSystemPath' agentTorHiddenServiceHostnamePath
 
 getAgentHiddenServiceUrlMaybe :: (HasFilesystemBase sig m, MonadIO m) => m (Maybe Text)
 getAgentHiddenServiceUrlMaybe = fmap T.strip <$> readSystemPath agentTorHiddenServiceHostnamePath
+
+-- | 'newTorManager' currently assumes the tor client lives on the localhost. The port comes in over an argument.
+-- If this is insufficient in the future, feel free to parameterize the host.
+newTorManager :: Word16 -> IO Manager
+newTorManager = newTlsManagerWith . mkManagerSettings def . Just . SockSettingsSimple "127.0.0.1" . fromIntegral

agent/src/Settings.hs

@@ -41,6 +41,9 @@ data AppSettings = AppSettings
     -- ^ Should all log messages be displayed?
     , appMgrVersionSpec         :: VersionRange
     , appFilesystemBase         :: Text
+    , appTorSocksPort           :: Word16
+    -- ^ Port on localhost where the tor client is listening, defaults to 9050
+    , appTorRestartCooldown     :: NominalDiffTime
     }
     deriving Show
 
@@ -63,6 +66,8 @@ instance FromJSON AppSettings where
 
         appMgrVersionSpec         <- o .: "app-mgr-version-spec"
         appFilesystemBase         <- o .: "filesystem-base"
+        appTorSocksPort           <- o .:? "tor-socks-port" .!= 9050
+        appTorRestartCooldown     <- o .:? "tor-restart-cooldown" .!= (secondsToNominalDiffTime 600)
         return AppSettings { .. }
 
 -- | Raw bytes at compile time of @config/settings.yml@