From 572feb3d6672aff5a60fb252b5ffbf0534427a0a Mon Sep 17 00:00:00 2001 From: mbays Date: Sun, 2 Oct 2022 00:00:00 +0000 Subject: [PATCH] show count of how often a cert has been temporarily trusted --- GeminiProtocol.hs | 20 +++++++++++++++++--- Mundanities.hs | 8 ++++++++ ServiceCerts.hs | 17 ++++++++++++++++- 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs index 963ddc9..07acea0 100644 --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -8,6 +8,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -315,10 +316,11 @@ makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ p checkTrust' errors = do let certs = map getCertificate signedCerts tailCert = head certs + tailHex = "SHA256:" <> fingerprintHex tailFingerprint serviceString = serviceToString service warnErrors = unless (null errors) . displayWarning $ [ "WARNING: tail certificate has verification errors: " <> show errors ] - known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr) + known <- loadServiceCert serviceCertsPath service if known == Just tailSigned then do displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ] when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint @@ -329,10 +331,16 @@ makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ p p <- promptYN df pprompt if p then return (True,True) else (False,) <$> promptYN df tprompt + tempTimes <- loadTempServiceInfo serviceCertsPath service >>= \case + Just (n,tempHex) | tempHex == tailHex -> pure n + _ -> pure 0 (saveCert,trust) <- case known of Nothing -> do displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ] warnErrors + when (tempTimes > 0) $ displayInfo [ + "This certificate has been temporarily trusted " <> + show tempTimes <> " times." ] let prompt = "provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" promptTrust True ("Permanently trust " ++ prompt) @@ -343,7 +351,8 @@ makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ p expired = currentTime > (snd . certValidity) trustedCert samePubKey = certPubKey trustedCert == certPubKey tailCert oldFingerprint = fingerprint trustedSignedCert - oldInfo = [ "Fingerprint of old certificate: SHA256:" ++ fingerprintHex oldFingerprint ] + oldHex = "SHA256:" <> fingerprintHex oldFingerprint + oldInfo = [ "Fingerprint of old certificate: " <> oldHex ] ++ fingerprintPicture oldFingerprint ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++ ": " ++ printExpiry trustedCert ] @@ -362,6 +371,9 @@ makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ p else displayWarning $ ("CAUTION: A certificate with a different public key for " ++ serviceString ++ " was previously explicitly trusted and has not expired!") : oldInfo + when (tempTimes > 0) $ displayInfo [ + "The new certificate has been temporarily trusted " <> + show tempTimes <> " times." ] warnErrors promptTrust (signedByOld || expired || samePubKey) ("Permanently trust new certificate" <> @@ -372,7 +384,9 @@ makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ p else " (but keep old certificate)") <> "?") when (saveCert && not readOnly) $ saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr - return trust + when (trust && not saveCert && not readOnly) $ + saveTempServiceInfo serviceCertsPath service (tempTimes + 1, tailHex) `catch` printIOErr + pure trust printExpiry :: Certificate -> String printExpiry = timePrint ISO8601_Date . snd . certValidity diff --git a/Mundanities.hs b/Mundanities.hs index 5133f2d..a8c83f2 100644 --- a/Mundanities.hs +++ b/Mundanities.hs @@ -15,6 +15,7 @@ module Mundanities where import Control.Applicative (Alternative, empty) import Control.Monad.Catch (MonadMask, handle) import Control.Monad.IO.Class (MonadIO, liftIO) +import Safe import System.Directory import System.FilePath @@ -50,6 +51,13 @@ readFileLines :: FilePath -> IO [T.Text] readFileLines path = ignoreIOErr $ map T.strip . T.lines . T.decodeUtf8 . BL.fromStrict <$> BS.readFile path +writeReadFile :: (Show a) => FilePath -> a -> IO () +writeReadFile path = BL.writeFile path . T.encodeUtf8 . T.pack . show + +readReadFile :: (Read a) => FilePath -> IO (Maybe a) +readReadFile path = ignoreIOErrAlt $ + readMay . T.unpack . T.decodeUtf8 . BL.fromStrict <$> BS.readFile path + -- delete all but last n lines of file truncateToEnd :: Int -> FilePath -> IO () truncateToEnd n path = diff --git a/ServiceCerts.hs b/ServiceCerts.hs index 9957a54..d65c223 100644 --- a/ServiceCerts.hs +++ b/ServiceCerts.hs @@ -16,7 +16,7 @@ import Data.List (elemIndex) import Data.PEM import Data.X509 import Data.X509.Validation -import System.Directory (doesFileExist, renamePath) +import System.Directory (doesFileExist, removeFile, renamePath) import System.FilePath import qualified Data.ByteString as BS @@ -45,10 +45,25 @@ loadServiceCert path service = _ -> Nothing _ -> Nothing) . pemParseBS <$> BS.readFile filepath +-- |'#' is illegal in a hostname, so this avoids clashes +tempSuffix :: String +tempSuffix = "#temp" + saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO () saveServiceCert path service cert = let filepath = path serviceToString service in isSubPath path filepath >>? do doesFileExist filepath >>? renamePath filepath (filepath ++ ".bk") + ignoreIOErr . removeFile $ filepath <> tempSuffix BS.writeFile filepath . pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert + +type TempServiceInfo = (Int,String) + +loadTempServiceInfo :: FilePath -> ServiceID -> IO (Maybe TempServiceInfo) +loadTempServiceInfo path service = + readReadFile $ path serviceToString service <> tempSuffix + +saveTempServiceInfo :: FilePath -> ServiceID -> TempServiceInfo -> IO () +saveTempServiceInfo path service = + writeReadFile (path serviceToString service <> tempSuffix) -- 2.11.4.GIT