diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +## 0.1.4 +* Indicate links to cached history items +* Retry with full handshake if session resume fails +* Recommend trust for new certificate signed by previous certificate +* Increase client cert validity to 50y +* Make ghost mode even more spectral + ## 0.1.3 * Allow trusting certificates just for the current session * Don't require tail certificates to be v3 diff --git a/ClientCert.hs b/ClientCert.hs --- a/ClientCert.hs +++ b/ClientCert.hs @@ -77,7 +77,7 @@ #endif saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type" --- |generate 2048bit RSA key with (-1y,+2y) validity +-- |generate 2048bit RSA key with (-1y,+50y) validity -- FIXME: these choices fingerprint the client generateSelfSigned :: String -> IO ClientCert generateSelfSigned cn = do @@ -86,7 +86,7 @@ currentTime <- timeConvert <$> timeCurrent let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)] sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA - to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 2, periodMonths = 0, periodDays = 0} + to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 50, periodMonths = 0, periodDays = 0} from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0} cert = Certificate { certVersion = 3 diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -130,7 +130,7 @@ topics = ["targets", "queue", "pager", "trust", "configuration" , "default_action", "proxies", "geminators", "render_filter" , "pre_display", "log_length", "max_wrap_width", "no_confirm" - , "copying", "topics"] + , "verbose_connection", "copying", "topics"] helpOn :: String -> [String] helpOn s = @@ -178,7 +178,7 @@ , " 7 : Go to link 7 from B. Call this location C." , " <<] : Go to link 4 from 'ex?foo. C is now set as the jump mark \"''\"." , " ''<] : Go to link 8 from B." - , " @/bar : Go to `ex/bar" + , " @/bar : Go to 'ex/bar" , "" , "Numbered, range, and search targets:" , " The specifiers \"$\", \"~\", \"<\", \">\", \"[\" and \"]\" all accept" @@ -320,6 +320,10 @@ , "" , "You are advised not to enable this until you are familiar with the behaviour of" , "the potentially dangerous commands like \"|\" and \"!\"" ] + "verbose_connection" -> + [ "{set} {verbose_connection} true: show extra information about connections" + , "{set} {verbose_connection} false: suppress extra information about connections" + ] "copying" -> [ "diohsc is free software, released under the terms of the GNU GPL v3 or later." , "You should have obtained a copy of the licence as the file COPYING." diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -15,12 +15,15 @@ import Control.Concurrent import Control.Exception -import Control.Monad (guard, mplus, unless, when) +import Control.Monad (guard, mplus, msum, unless, void, + when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Default.Class (def) import Data.Hourglass import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix, transpose) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.X509 import Data.X509.CertificateStore import Data.X509.Validation hiding (Fingerprint (..), @@ -104,6 +107,7 @@ CertificateStore (MVar (Set.Set Fingerprint)) (MVar (Set.Set Fingerprint)) + (MVar (Set.Set String)) FilePath Bool ClientSessions @@ -113,12 +117,14 @@ let certPath = path "trusted_certs" serviceCertsPath = path "known_hosts" in do - mkdirhier certPath - mkdirhier serviceCertsPath + unless readOnly $ do + mkdirhier certPath + mkdirhier serviceCertsPath certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath mTrusted <- newMVar Set.empty - mIgnoredErrors <- newMVar Set.empty - RequestContext callbacks certStore mTrusted mIgnoredErrors serviceCertsPath readOnly <$> newClientSessions + mIgnoredCertErrors <- newMVar Set.empty + mIgnoredCCertWarnings <- newMVar Set.empty + RequestContext callbacks certStore mTrusted mIgnoredCertErrors mIgnoredCCertWarnings serviceCertsPath readOnly <$> newClientSessions requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request requestOfProxiesAndUri proxies uri = @@ -153,9 +159,10 @@ makeRequest :: RequestContext -> Maybe Identity -- ^client certificate to offer -> Int -- ^bound in bytes for response stream buffering + -> Bool -- ^whether to display extra information about connection -> Request -> IO (Either SomeException (Response, IO ())) makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN) - certStore mTrusted mIgnoredErrors serviceCertsPath readOnly clientSessions) mIdent bound (NetworkRequest (Host hostname port) uri) = + certStore mTrusted mIgnoredCertErrors mIgnoredCCertWarnings serviceCertsPath readOnly clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) = let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n" uriLength = BS.length requestBytes - 2 ccfp = clientCertFingerprint . identityCert <$> mIdent @@ -172,10 +179,16 @@ Nothing -> return Nothing Just ident@(Identity idName (ClientCert chain key)) -> do let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs - conf <- if isTemporary ident || is13 then return True else do - displayWarning ["Pre-TLS1.3 server: identity " <> idName <> " might be revealed to eavesdroppers!"] - promptYN False "Identify anyway?" - return $ if conf then Just (chain,key) else Nothing + allow <- if isTemporary ident || is13 then return True else do + ignored <- (idName `Set.member`) <$> readMVar mIgnoredCCertWarnings + if ignored then return True else do + displayWarning ["Pre-TLS1.3 server: identity " + <> idName <> " might be revealed to eavesdroppers!"] + conf <- promptYN False "Identify anyway?" + when conf $ modifyMVar_ mIgnoredCCertWarnings + (return . Set.insert idName) + return conf + return $ if allow then Just (chain,key) else Nothing } , clientShared = def { sharedCAStore = certStore @@ -183,12 +196,26 @@ , clientEarlyData = Just requestBytes -- ^Send early data (RTT0) if server session allows it , clientWantSessionResume = session } - sock <- openSocket - context <- TLS.contextNew sock params - handshake context + (sock,context) <- do + let retryNoResume e@(HandshakeFailed (Error_Protocol (_,_,HandshakeFailure))) + | isJust session = do + -- Work around a mysterious problem seen with dezhemini+libssl: + displayWarning [ "Handshake failure when resuming TLS session; retrying with full handshake." ] + sock <- openSocket + c <- TLS.contextNew sock $ params { clientWantSessionResume = Nothing } + handshake c >> return (sock,c) + retryNoResume e = throw e + sock <- openSocket + c <- TLS.contextNew sock params + handle retryNoResume $ handshake c >> return (sock,c) sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context unless sentEarly . sendData context $ BL.fromStrict requestBytes - -- print =<< (infoTLS13HandshakeMode <$>) <$> contextGetInformation context + when verboseConnection . void . runMaybeT $ do + info <- MaybeT $ contextGetInformation context + lift . displayInfo $ [ "TLS version " ++ show (infoVersion info) ++ + ", cipher " ++ cipherName (infoCipher info) ] + mode <- MaybeT . return $ infoTLS13HandshakeMode info + lift . displayInfo $ [ "Handshake mode " ++ show mode ] chan <- newBSChan bound let recvAllLazily = do r <- recvData context @@ -219,7 +246,7 @@ if null errors || any isTrustError errors || null signedCerts then return errors else do - ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredErrors + ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredCertErrors if ignored then return [] else do displayWarning [ "Certificate chain has trusted root, but validation errors: " @@ -227,10 +254,10 @@ displayWarning $ showChain signedCerts ignore <- promptYN False "Ignore errors?" if ignore - then modifyMVar_ mIgnoredErrors (return . Set.insert tailFingerprint) >> return [] + then modifyMVar_ mIgnoredCertErrors (return . Set.insert tailFingerprint) >> return [] else return errors where - isTrustError = (`elem` [UnknownCA, SelfSigned]) + isTrustError = (`elem` [UnknownCA, SelfSigned, NotAnAuthority]) -- |error pertaining to the tail certificate, to be ignored if the -- user explicitly trusts the certificate for this service. @@ -241,6 +268,16 @@ tailSigned = head signedCerts tailFingerprint = fingerprint tailSigned + chainSigsFail :: Maybe SignatureFailure + chainSigsFail = + let verify (signed:signing:rest) = msum [ + case verifySignedSignature signed . certPubKey $ getCertificate signing of + SignaturePass -> Nothing + SignatureFailed failure -> Just failure + , verify (signing:rest) ] + verify _ = Nothing + in verify signedCerts + doTofu errors = if not . any isTrustError $ errors then return errors else do @@ -257,6 +294,9 @@ when trust $ modifyMVar_ mTrusted (return . Set.insert tailFingerprint) return trust checkTrust' :: [FailedReason] -> IO Bool + checkTrust' _ | Just sigFail <- chainSigsFail = do + displayWarning [ "Invalid signature in certificate chain: " ++ show sigFail ] + return False checkTrust' errors = do let certs = map getCertificate signedCerts tailCert = head certs @@ -266,6 +306,7 @@ known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr) if known == Just tailSigned then do displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ] + when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint return True else do displayInfo $ showChain signedCerts @@ -291,8 +332,15 @@ ++ fingerprintPicture oldFingerprint ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++ ": " ++ printExpiry trustedCert ] - if expired || samePubKey + signedByOld = SignaturePass `elem` + ((`verifySignedSignature` certPubKey trustedCert) <$> signedCerts) + if signedByOld then displayInfo $ + ("The new certificate chain is signed by " ++ + (if expired then "an EXPIRED" else "a") ++ + " key previously trusted for this host.") : oldInfo + else if expired || samePubKey + then displayInfo $ ("A different " ++ (if expired then "expired " else "non-expired ") ++ "certificate " ++ (if samePubKey then "with the same public key " else "") ++ "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo @@ -300,7 +348,7 @@ ("CAUTION: A certificate with a different public key for " ++ serviceString ++ " was previously explicitly trusted and has not expired!") : oldInfo warnErrors - promptTrust (expired || samePubKey) + promptTrust (signedByOld || expired || samePubKey) ("Permanently trust new certificate" <> (if readOnly then "" else " (and delete old certificate)") <> "?") ("Temporarily trust new certificate" <> @@ -402,4 +450,4 @@ _ -> Failure status meta _ -> MalformedResponse (BadStatus statusString) -makeRequest _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest" +makeRequest _ _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest" diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.3.1 +VERSION=0.1.4 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa @@ -33,7 +33,7 @@ diohsc-${VERSION}-src.tgz: dist-newstyle/sdist/diohsc-${VERSION}.tar.gz cp $< $@ -index.gmi: index.gmi.in +index.gmi: index.gmi.in Makefile cat $< | sed 's/\$$VERSION/${VERSION}/g' > $@ index.html: index.gmi diff --git a/Pager.hs b/Pager.hs --- a/Pager.hs +++ b/Pager.hs @@ -46,6 +46,7 @@ let col = fromMaybe 0 mcol liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " " c <- liftIO . promptChar . withBoldStr $ drop (col + 4 - termWidth) " --" + liftIO $ putStrLn "" let rest = l:ls case toLower <$> c of Nothing -> return () diff --git a/Prompt.hs b/Prompt.hs --- a/Prompt.hs +++ b/Prompt.hs @@ -53,16 +53,16 @@ bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ do putStr prompt hFlush stdout - c <- runInputTDefWithAbortValue Nothing . lift $ Just <$> getChar - putStrLn "" - return c + runInputTDefWithAbortValue Nothing . lift $ Just <$> getChar where bracketSet get set v f = bracket get set $ \_ -> set v >> f promptYN :: Bool -> Bool -> String -> IO Bool promptYN False def _ = return def -promptYN True def prompt = - xor def . (`elem` map Just (if def then "nN" else "yY")) +promptYN True def prompt = do + answer <- xor def . (`elem` map Just (if def then "nN" else "yY")) <$> promptChar (prompt ++ if def then " [Y/n] " else " [y/N] ") + putStrLn $ if answer then "y" else "n" + return answer promptPassword :: String -> IO (Maybe String) promptPassword = runInputTDefWithAbortValue Nothing . HL.getPassword (Just '*') . escapePromptCSI diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -16,4 +16,4 @@ programName = "diohsc" version :: String -version = "0.1.3.1" +version = "0.1.4" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: diohsc -version: 0.1.3.1 +version: 0.1.4 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -142,18 +142,19 @@ historyAncestors i ++ [i] ++ historyDescendants i data ClientConfig = ClientConfig - { clientConfDefaultAction :: (String, [CommandArg]) - , clientConfProxies :: M.Map String Host - , clientConfGeminators :: [(String,(Regex,String))] - , clientConfRenderFilter :: Maybe String - , clientConfPreOpt :: PreOpt - , clientConfMaxLogLen :: Int - , clientConfMaxWrapWidth :: Int - , clientConfNoConfirm :: Bool + { clientConfDefaultAction :: (String, [CommandArg]) + , clientConfProxies :: M.Map String Host + , clientConfGeminators :: [(String,(Regex,String))] + , clientConfRenderFilter :: Maybe String + , clientConfPreOpt :: PreOpt + , clientConfMaxLogLen :: Int + , clientConfMaxWrapWidth :: Int + , clientConfNoConfirm :: Bool + , clientConfVerboseConnection :: Bool } defaultClientConfig :: ClientConfig -defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre 1000 80 False +defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre 1000 80 False False data QueueItem = QueueItem { queueOrigin :: Maybe HistoryOrigin @@ -233,10 +234,12 @@ let ghost = Ghost `elem` opts - mkdirhier userDataDir + unless ghost $ do + mkdirhier userDataDir #ifndef WINDOWS - setFileMode userDataDir ownerModes -- chmod 700 + setFileMode userDataDir ownerModes -- chmod 700 #endif + let cmdHistoryPath = userDataDir "commandHistory" marksPath = userDataDir "marks" logPath = userDataDir "log" @@ -266,7 +269,7 @@ closeLog :: Maybe Handle -> IO () closeLog = maybe (return ()) hClose - bracketOnError openLog closeLog $ \logH -> + (if ghost then ($ Nothing) else bracketOnError openLog closeLog) $ \logH -> let clientOptions = ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH initState = emptyClientState {clientMarks = marks @@ -287,7 +290,7 @@ getTermSize :: IO (Int,Int) getTermSize = do - Size.Window height width <- fromMaybe (Size.Window 25 80) <$> Size.size + Size.Window height width <- fromMaybe (Size.Window (2^31) 80) <$> Size.size return (height,width) lineClient :: ClientOptions -> [String] -> HL.InputT ClientM () @@ -406,7 +409,7 @@ handleCommandLine cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH) cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _ - (ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm)) + (ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm verboseConnection)) = \(CommandLine mt mcas) -> case mcas of Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases -> let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args @@ -481,7 +484,8 @@ showUriFull ansi' ais base uri = let scheme = uriScheme uri handled = scheme `elem` ["gemini","file"] || M.member scheme proxies - col = case (isVisited uri,handled) of + inHistory = isJust $ curr >>= flip pathItemByUri uri + col = if inHistory then BoldBlue else case (isVisited uri,handled) of (True,True) -> Yellow (False,True) -> BoldYellow (True,False) -> Red @@ -742,6 +746,7 @@ putStrLn $ expand "{log_length}: " <> show maxLogLen putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth putStrLn $ expand "{no_confirm}: " <> show noConfirm + putStrLn $ expand "{verbose_connection}: " <> show verboseConnection where printMap :: (a -> String) -> [(String,a)] -> IO () printMap f as = mapM_ putStrLn $ @@ -793,6 +798,12 @@ [CommandArg s _] | map toLower s `isPrefixOf` "false" -> modifyCConf $ \c -> c { clientConfNoConfirm = False } _ -> printErr "Require \"true\" or \"false\" as value for no_confirm" + | opt `isPrefixOf` "verbose_connection" = case val of + [CommandArg s _] | map toLower s `isPrefixOf` "true" -> + modifyCConf $ \c -> c { clientConfVerboseConnection = True } + [CommandArg s _] | map toLower s `isPrefixOf` "false" -> + modifyCConf $ \c -> c { clientConfVerboseConnection = False } + _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection" | otherwise = printErr $ "No such option \"" <> opt <> "\"." handleCommand [] cargs = case curr of @@ -862,7 +873,6 @@ repl origin uri = repl' where repl' = liftIO (promptInput ">> ") >>= \case Nothing -> return () - Just "" -> return () Just query -> do goUri True origin . setQuery ('?':escapeQuery query) $ uri repl' @@ -893,9 +903,10 @@ actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do createDirectoryIfMissing True savesDir homePath <- getHomeDirectory - let path' = if take 2 path == "~/" - then homePath drop 2 path - else savesDir path + let path' + | take 2 path == "~/" = homePath drop 2 path + | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path + | otherwise = savesDir path body = mimedBody $ historyMimedData item name = fromMaybe "" . lastMay . pathSegments $ historyUri item handle printIOErr . void . runMaybeT $ do @@ -906,7 +917,7 @@ lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory" mzero lift (doesFileExist fullpath) >>? - guard . not =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?") + guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?") lift $ do putStrLn $ "Saving to " ++ fullpath t0 <- timeCurrentP @@ -987,7 +998,7 @@ modify $ \s -> s { clientActiveIdentities = ais } printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream - liftIO (makeRequest requestContext mId respBuffSize req) + liftIO (makeRequest requestContext mId respBuffSize verboseConnection req) `bracket` either (\_ -> return ()) (liftIO . snd) $ either (printErr . displayException) @@ -1010,9 +1021,9 @@ warningStr = colour BoldRed ais <- gets clientActiveIdentities proceed <- (isJust <$>) . lift . runMaybeT $ do - when crossSite . guard <=< (liftIO . promptYN False) $ + when crossSite $ guard <=< (liftIO . promptYN False) $ warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?" - when crossScheme . guard <=< (liftIO . promptYN False) $ + when crossScheme $ guard <=< (liftIO . promptYN False) $ warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?" when proceed $ do when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks