diohsc 0.1.3.1 → 0.1.4
raw patch · 10 files changed
+128/−57 lines, 10 files
Files
- CHANGELOG.md +7/−0
- ClientCert.hs +2/−2
- Command.hs +6/−2
- GeminiProtocol.hs +69/−21
- Makefile +2/−2
- Pager.hs +1/−0
- Prompt.hs +5/−5
- Version.hs +1/−1
- diohsc.cabal +1/−1
- diohsc.hs +34/−23
CHANGELOG.md view
@@ -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
ClientCert.hs view
@@ -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
Command.hs view
@@ -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."
GeminiProtocol.hs view
@@ -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"
Makefile view
@@ -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
Pager.hs view
@@ -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 ()
Prompt.hs view
@@ -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
Version.hs view
@@ -16,4 +16,4 @@ programName = "diohsc" version :: String-version = "0.1.3.1"+version = "0.1.4"
diohsc.cabal view
@@ -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
diohsc.hs view
@@ -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