diff --git a/ActiveIdentities.hs b/ActiveIdentities.hs --- a/ActiveIdentities.hs +++ b/ActiveIdentities.hs @@ -55,7 +55,7 @@ Just (root, (ident, lastUsed)) -> do currentTime <- timeCurrent use <- if currentTime - lastUsed > Elapsed 1800 - then promptYN (not noConfirm) False $ if isTemporary ident + then promptYN (not noConfirm) noConfirm $ if isTemporary ident then "Reuse old anonymous identity?" else "Continue to use identity " ++ showIdentity ansi ident ++ "?" else return True diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.8 +* Use standard PEM/DER format for identities, allowing import/export +* Optionally generate Ed25519 client certificates ("TARGET id NAME ed") +* Require confirmation before following redirect into scope of identity +* TOFU-trust by default even if there are V3 or NameMismatch errors + # 0.1.7 * Handle ^C during streaming by truncating the stream * Always request when going to uris using an identity diff --git a/ClientCert.hs b/ClientCert.hs --- a/ClientCert.hs +++ b/ClientCert.hs @@ -9,29 +9,37 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module ClientCert where -import Control.Applicative (liftA2) -import Crypto.Hash.Algorithms (SHA256 (..)) +import Control.Applicative (liftA2) +import Control.Monad (join, (<=<)) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Crypto.Hash.Algorithms (SHA256 (..)) import Crypto.PubKey.RSA -import Crypto.PubKey.RSA.PKCS15 +import Data.ASN1.BinaryEncoding (DER (..)) +import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.OID -import Data.ASN1.Types.String (ASN1StringEncoding (UTF8)) -import Data.Either (fromRight) +import Data.ASN1.Types (ASN1Object (..)) +import Data.ASN1.Types.String (ASN1StringEncoding (UTF8)) +import Data.Either (fromRight) +import Data.Foldable (msum) import Data.Hourglass import Data.PEM import Data.X509 -import Network.TLS (PrivKey (PrivKeyRSA)) +import Network.TLS (PrivKey (PrivKeyRSA)) import Safe import System.FilePath import Time.System -import qualified Data.ByteString as BS -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15 +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS import Fingerprint import Mundanities @@ -49,33 +57,51 @@ clientCertFingerprint (ClientCert (CertificateChain chain) _) = fingerprint $ head chain +maybeRight :: Either a b -> Maybe b +maybeRight (Left _) = Nothing +maybeRight (Right b) = Just b + loadClientCert :: FilePath -> String -> IO (Maybe ClientCert) loadClientCert path name = let certpath = path name <.> "crt" - keypath = path name <.> "rsa" - in ignoreIOErrAlt $ do - chain <- (\case - Right pems -> case decodeCertificateChain . CertificateChainRaw $ map pemContent pems of - Right chain -> Just chain - _ -> Nothing - _ -> Nothing) . pemParseBS <$> BS.readFile certpath - key <- (PrivKeyRSA <$>) . readMay <$> readFile keypath - return $ liftA2 ClientCert chain key + legacyKeypath = path name <.> "rsa" + keypath = path name <.> "key" + in ignoreIOErrAlt . runMaybeT $ do + chain <- MaybeT $ + (maybeRight . decodeCertificateChain . CertificateChainRaw . map pemContent + <=< maybeRight . pemParseBS) + <$> BS.readFile certpath + key <- msum + [ MaybeT $ (maybeRight . (fst <$>) . fromASN1 + <=< maybeRight . decodeASN1' DER . pemContent + <=< headMay + <=< maybeRight . pemParseBS) + <$> ignoreIOErr (BS.readFile keypath) + , do + -- Legacy private rsa key format: Show instance of PrivateKey + key <- MaybeT $ (PrivKeyRSA <$>) . readMay <$> ignoreIOErr (readFile legacyKeypath) + -- Upgrade to standard format + lift . saveClientCert path name $ ClientCert chain key + return key + ] + return $ ClientCert chain key saveClientCert :: FilePath -> String -> ClientCert -> IO () -saveClientCert path name (ClientCert chain (PrivKeyRSA key)) = +saveClientCert path name (ClientCert chain key) = let filepath = path name certpath = filepath <.> "crt" - keypath = filepath <.> "rsa" + keypath = filepath <.> "key" in isSubPath path filepath >>? ignoreIOErr $ do let CertificateChainRaw rawCerts = encodeCertificateChain chain chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts BS.writeFile certpath $ BS.intercalate "\n" chainPEMs - writeFile keypath $ show key + BS.writeFile keypath . pemWriteBS . PEM "PRIVATE KEY" [] . encodeDER $ key #ifndef WINDOWS setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600 #endif -saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type" + where + encodeDER :: ASN1Object o => o -> BS.ByteString + encodeDER = encodeASN1' DER . (`toASN1` []) -- RFC5280: To indicate that a certificate has no well-defined expiration -- date, the notAfter SHOULD be assigned the GeneralizedTime value of @@ -88,56 +114,41 @@ notBeforeMin :: DateTime notBeforeMin = DateTime (Date 1950 January 1) (TimeOfDay 0 0 0 0) --- |generate 2048bit RSA key with maximum validity -generateSelfSigned :: String -> IO ClientCert -generateSelfSigned cn = do - (pubKey, secKey) <- generate 256 65537 - blinder <- generateBlinder $ public_n pubKey - let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)] - sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA +data KeyType = KeyRSA | KeyEd25519 + +generateSelfSigned :: KeyType -> String -> IO ClientCert +generateSelfSigned tp cn = + let dn = DistinguishedName [(getObjectID DnCommonName, + ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)] + sigAlg = case tp of + KeyRSA -> SignatureALG HashSHA256 PubKeyALG_RSA + KeyEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519 to = timeConvert notAfterMax from = timeConvert notBeforeMin - cert = Certificate + cert certPubKey = Certificate { certVersion = 2 , certSerial = 0 , certSignatureAlg = sigAlg , certIssuerDN = dn , certSubjectDN = dn , certValidity = (from, to) - , certPubKey = PubKeyRSA pubKey - , certExtensions = Extensions Nothing - } - signed = fst $ objectToSignedExact - (\b -> (fromRight BS.empty $ sign (Just blinder) (Just SHA256) secKey b, sigAlg, ())) - cert - return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey) - -{- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for --- gemini, we should use this? -import qualified Data.ByteArray as BA - -generateSelfSigned :: String -> IO ClientCert -generateSelfSigned cn = do - secKey <- generateSecretKey - currentTime <- timeConvert <$> timeCurrent - let pubKey = toPublic secKey - dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)] - sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 - -- TODO: think about correct validity dates - to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 1, periodMonths = 0, periodDays = 0} - from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0} - cert = Certificate - { certVersion = 3 - , certSerial = 0 - , certSignatureAlg = sigAlg - , certIssuerDN = dn - , certSubjectDN = dn - , certValidity = (from, to) - , certPubKey = PubKeyEd25519 pubKey + , certPubKey = certPubKey , certExtensions = Extensions Nothing } - signed = fst $ objectToSignedExact - (\b -> (BS.pack . BA.unpack $ sign secKey pubKey b, sigAlg, ())) - cert - return (CertificateChain [signed], PrivKeyEd25519 secKey) --} + in case tp of + KeyRSA -> do + -- generate 2048bit RSA self-signed cert with maximum validity + (pubKey, secKey) <- generate 256 65537 + blinder <- generateBlinder $ public_n pubKey + let signed = fst $ objectToSignedExact + (\b -> (fromRight BS.empty $ + PKCS15.sign (Just blinder) (Just SHA256) secKey b, sigAlg, ())) + (cert $ PubKeyRSA pubKey) + return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey) + KeyEd25519 -> do + secKey <- Ed25519.generateSecretKey + let pubKey = Ed25519.toPublic secKey + let signed = fst $ objectToSignedExact + (\b -> (BS.pack . BA.unpack $ Ed25519.sign secKey pubKey b, sigAlg, ())) + (cert $ PubKeyEd25519 pubKey) + return $ ClientCert (CertificateChain [signed]) (PrivKeyEd25519 secKey) diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -314,7 +314,7 @@ "log_length" -> [ "{set} {log_length} N: set number of items to store in log" , "{set} {log_length} 0: clear log and disable logging" - , "see also: {log}" ] + , "See also: {log}" ] "max_wrap_width" -> [ "{set} {max_wrap_width} N: set maximum width for text wrapping" ] "no_confirm" -> @@ -353,7 +353,7 @@ , "they and their ancestors can be manipulated without causing network requests." ] "inventory" -> [ "{inventory}: show current queue (~N), path (N), and session marks ('N)." - , "see also: {log}" ] + , "See also: {log}" ] "log" -> [ "{log}: show log." , "TARGETS {log}: add targets to log." @@ -375,6 +375,10 @@ , "An \"identity\" is a cryptographic certificate," , "sent to the server to securely identify you to the server." , "An identity which will be used for a request is indicated as \"{%Yellow%uri}[{%Green%identity}]\"." + , "" + , "TARGET {identify} IDENTITY ed: create identity with an Ed25519 key pair" + , "Ed25519 uses much smaller keys than the default RSA algorithm," + , "but some servers may fail to accept identities created using it." , "See also: {configuration}" ] "add" -> [ "TARGETS {add}: add targets to the end of the queue." diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -36,6 +36,7 @@ import Network.URI (isIPv4address, isIPv6address) import Safe import System.FilePath +import System.IO.Error (catchIOError) import Time.System import qualified Data.ByteString as BS @@ -188,11 +189,13 @@ , onCertificateRequest = \(_,pairs,_) -> case mIdent of Nothing -> return Nothing Just ident@(Identity idName (ClientCert chain key)) -> do + -- Note: I have once seen this way of detecting + -- pre-tls1.3 give a false positive. let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs 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 " + displayWarning ["This may be a pre-TLS1.3 server: identity " <> idName <> " might be revealed to eavesdroppers!"] conf <- promptYN False "Identify anyway?" when conf $ modifyMVar_ mIgnoredCCertWarnings @@ -230,9 +233,12 @@ let recvAllLazily = do r <- recvData context unless (BS.null r) $ writeBSChan chan r >> recvAllLazily + ignoreIOError = (`catchIOError` (const $ return ())) recvThread <- forkFinally recvAllLazily $ \_ -> -- |XXX: note that writeBSChan can't block when writing BS.empty - writeBSChan chan BS.empty >> bye context >> closeSock sock + writeBSChan chan BS.empty + >> ignoreIOError (bye context) + >> closeSock sock lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan return $ Right (lazyResp, killThread recvThread) where @@ -268,6 +274,8 @@ -- |error pertaining to the tail certificate, to be ignored if the -- user explicitly trusts the certificate for this service. + -- These don't actually affect the TOFU-trustworthiness of a + -- certificate, but we warn the user about them anyway. isTrustableError LeafNotV3 = True isTrustableError (NameMismatch _) = True isTrustableError _ = False @@ -327,7 +335,7 @@ warnErrors let prompt = "provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" - promptTrust (null errors) ("Permanently trust " ++ prompt) + promptTrust True ("Permanently trust " ++ prompt) ("Temporarily trust " ++ prompt) Just trustedSignedCert -> do currentTime <- timeConvert <$> timeCurrent diff --git a/Identity.hs b/Identity.hs --- a/Identity.hs +++ b/Identity.hs @@ -45,18 +45,21 @@ loadIdentity :: FilePath -> String -> IO (Maybe Identity) loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName -getIdentity :: Bool -> Bool -> FilePath -> String -> IO (Maybe Identity) -getIdentity _ _ _ "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned "") -getIdentity interactive ansi idsPath idName' = runMaybeT $ do +getIdentity :: Bool -> Bool -> FilePath -> KeyType -> String -> IO (Maybe Identity) +getIdentity _ _ _ tp "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned tp "") +getIdentity interactive ansi idsPath tp idName' = runMaybeT $ do idName <- MaybeT . return $ normaliseIdName idName' msum [ MaybeT $ loadIdentity idsPath idName , do when interactive . lift $ do - putStrLn "Creating a new long-term identity." + let keyTypeName = case tp of + KeyRSA -> "RSA" + KeyEd25519 -> "Ed25519" + putStrLn $ "Creating a new " ++ keyTypeName ++ " identity." putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";" putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username." putStrLn "The common name may be left blank. Use ^C to cancel identity generation." - clientCert <- liftIO . generateSelfSigned . fromMaybe "" =<< + clientCert <- liftIO . generateSelfSigned tp . fromMaybe "" =<< if not interactive then return Nothing else MaybeT (promptLine "Common Name: ") liftIO $ mkdirhier idsPath lift $ saveClientCert idsPath idName clientCert @@ -72,7 +75,7 @@ let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": " idName <- (fromMaybe "" <$>) . MaybeT $ promptLineWithCompletions prompt =<< listIdentities idsPath - MaybeT $ getIdentity True ansi idsPath idName + MaybeT $ getIdentity True ansi idsPath KeyRSA idName listIdentities :: FilePath -> IO [String] listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path) diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.7 +VERSION=0.1.8 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa @@ -25,7 +25,7 @@ rm diohsc *.hi *.o diohsc.1: diohsc.1.md - pandoc --standalone -f markdown -t man < diohsc.1.md >| diohsc.1 + pandoc --standalone -f markdown -t man < diohsc.1.md | sed 's/\$$VERSION/${VERSION}/g' >| diohsc.1 dist-newstyle/sdist/diohsc-${VERSION}.tar.gz: *.hs README.md CHANGELOG.md COPYING *.cabal *.sample diohsc.1 cabal sdist @@ -33,6 +33,9 @@ diohsc-${VERSION}-src.tgz: dist-newstyle/sdist/diohsc-${VERSION}.tar.gz cp $< $@ +diohsc.bundle: .git/refs/heads/master + git bundle create "$@" HEAD master + index.gmi: index.gmi.in Makefile cat $< | sed 's/\$$VERSION/${VERSION}/g' > $@ @@ -48,6 +51,6 @@ %.html: %.gmi ./tools/gmi2html.sed < $< > $@ -publish: diohsc-${VERSION}-src.tgz index.gmi index.html README.md README.gmi README.html CHANGELOG.gmi CHANGELOG.md CHANGELOG.html tutorial/diohsc-tutorial.cast tutorial/diohsc-tutorial.txt +publish: diohsc-${VERSION}-src.tgz diohsc.bundle index.gmi index.html README.md README.gmi README.html CHANGELOG.gmi CHANGELOG.md CHANGELOG.html tutorial/diohsc-tutorial.cast tutorial/diohsc-tutorial.txt cp $^ /var/gemini/gemini.thegonz.net/diohsc/ scp $^ sverige:html/diohsc/ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,12 +24,11 @@ The resulting binary will be installed as `~/.cabal/bin/diohsc`. ### Compile-time options -libmagic can be used to detect mimetypes of local files; try: `cabal install -f Magic` +* `cabal install -f magic`: use libmagic to detect mimetypes of local files +* `cabal install -f irilinks`: allow IRIs in gemtext links ## Trusting server certificates -First, a disclaimer: do not trust this software to keep you secure. Although everything seems to be working as intended, and though the libraries it depends on seem solid, this is "very alpha" software and should not be relied on. - -diohsc uses "Trust On First Use": if a host provides a certificate chain you do not currently trust, the client will ask for confirmation then add the certificate for the host to a collection stored in `~/.diohsc/known_hosts/` if there isn't already one stored; if there is one already stored, it will give some details and ask if you want to overwrite it with the newly provided one. +Diohsc uses "Trust On First Use": if a host provides a certificate chain you do not currently trust, the client will ask for confirmation then add the certificate for the host to a collection stored in `~/.diohsc/known_hosts/` if there isn't already one stored; if there is one already stored, it will give some details and ask if you want to overwrite it with the newly provided one. You can also trust Certificate Authorities by putting their certificates in `~/.diohsc/trusted_certs/`. For example, if you want to trust all the certificates installed on your system, ``` @@ -44,7 +43,7 @@ ``` ## Configuration -See diohscrc.sample for ideas for configuration options, in particular indicating how to make use of third-party software to allow diohsc to access gopher, and parse markdown and html, and provide ascii-art previews of image files. Copy the file to ~/.diohsc/diohscrc and uncomment lines as appropriate. +See diohscrc.sample for ideas for configuration options, in particular indicating how to make use of third-party software to allow diohsc to access gopher and the web, parse markdown and html, and provide ascii-art previews of image files. Copy the file to ~/.diohsc/diohscrc and uncomment lines as appropriate. ## Multiple instances Multiple simultaneous diohsc instances may share ~/.diohsc without serious conflict. However, command history is written only on exit, so the last instance to exit will determine that history. The log is appended to continuously, but read only on startup, so logs from simultaneous instances will be interleaved. Uris in ~/.diohsc/queue are taken by an instance on startup and whenever it processes a command, and leftover queue items are written there on exit. diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -78,10 +78,12 @@ printLine (PreformattedLine alt line) | preOpt == PreOptAlt && not (T.null alt) = [] | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line - printLine (HeadingLine level line) = (:[]) $ if ansi - then applyIf (level /= 2) withUnderlineStr . - applyIf (level < 3) withBoldStr $ line - else T.take (fromIntegral level) (T.repeat '#') <> " " <> line + printLine (HeadingLine level line) = (:[]) + . ((T.take (fromIntegral level) (T.repeat '#') <> " ") <>) + . applyIf ansi + ( applyIf (level /= 2) withUnderlineStr + . applyIf (level < 3) withBoldStr ) + $ line printLine (ItemLine line) = wrapWith "* " False line printLine (QuoteLine line) = wrapWith "> " True line printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red) diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -158,12 +158,12 @@ escapeQuery = NU.escapeURIString isUnescapedInQuery . withEscapes where withEscapes "" = "" - withEscapes ('\\':'\\':s) = '\\':withEscapes s withEscapes ('\\':'x':h1:h2:s) | Just c <- readMay $ "'\\x" <> [h1,h2,'\''] = c:withEscapes s withEscapes ('\\':'e':s) = '\ESC':withEscapes s withEscapes ('\\':'r':s) = '\r':withEscapes s withEscapes ('\\':'n':s) = '\n':withEscapes s withEscapes ('\\':'t':s) = '\t':withEscapes s + withEscapes ('\\':c:s) = c:withEscapes s withEscapes (c:s) = c:withEscapes s -- |escape the query part of an unparsed uri string 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.7" +version = "0.1.8" diff --git a/diohsc.1.md b/diohsc.1.md --- a/diohsc.1.md +++ b/diohsc.1.md @@ -108,8 +108,10 @@ : URI, optionally appended by [IDENT] where IDENT is the name of an identity. ~/.diohsc/identities/ -: Contains client certificates and corresponding private RSA keys for named +: Contains client certificates and corresponding private keys for named : cryptographic identities, as produced by the "identify" command. +: These are stored in standard PEM/DER format, so can be imported/exported +: from/to other clients. ~/.diohsc/queue : Contains URIs, one per line. On startup and before processing each command, @@ -125,9 +127,6 @@ # BUGS Only ANSI escape sequences are supported. - -Private keys for identities are stored in an ad hoc non-standard format, -making it impossible to share identities between diohsc and other clients. # LICENCE diohsc is free software, released under the terms of the GNU GPL v3 or later. 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.7 +version: 0.1.8 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org @@ -41,6 +41,7 @@ description: Allow IRIs in gemtext links (preparing for likely spec change). Punycoding is not currently supported. + default: False manual: True @@ -78,10 +79,11 @@ ghc-options: -threaded build-depends: base >=4.3 && <5, + asn1-encoding <0.10, asn1-types >=0.3.4 && <0.4, - bytestring >=0.10.4.0 && <0.11, + bytestring >=0.10.4.0 && <0.12, containers >=0.5.5.1 && <0.7, - cryptonite >=0.26 && <0.28, + cryptonite >=0.26 && <0.30, data-default-class >=0.1.2.0 && <0.2, data-hash >=0.2.0.1 && <0.3, directory >=1.2.1.0 && <1.4, @@ -92,8 +94,9 @@ hourglass >=0.2.12 && <0.3, mime >=0.4.0.2 && <0.5, mtl >=2.1.3.1 && <2.3, + memory >=0.14 && <0.17, network >=2.4.2.3 && <3.2, - network-simple >=0.4.3 && <5, + network-simple >=0.4.3 && <0.5, network-uri >=2.6.3.0 && <2.8, parsec >=3.1.5 && <3.2, pem >=0.2.4 && <0.3, @@ -120,7 +123,7 @@ build-depends: magic <1.2 if flag(irilinks) - cpp-options: -DIRILinks + cpp-options: -DIRILinks if (!os(windows) || flag(libiconv)) cpp-options: -DICONV diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -57,6 +57,7 @@ import ActiveIdentities import Alias import qualified BStack +import ClientCert (KeyType (..)) import Command import CommandLine import GeminiProtocol @@ -871,10 +872,14 @@ Just (root,(ident,_)) | null args -> endIdentityPrompted root ident _ -> void . runMaybeT $ do ident <- MaybeT . liftIO $ case args of - (CommandArg idName _ : _) -> getIdentity interactive ansi idsPath idName + CommandArg idName _ : args' -> + let tp = case args' of + CommandArg ('e':'d':_) _ : _ -> KeyEd25519 + _ -> KeyRSA + in getIdentity interactive ansi idsPath tp idName [] -> if interactive then getIdentityRequesting ansi idsPath - else getIdentity interactive ansi idsPath "" + else getIdentity interactive ansi idsPath KeyRSA "" lift $ addIdentity req ident handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do cmd <- case args of @@ -1047,16 +1052,20 @@ handleResponse (Success mimedData) = doAction req mimedData handleResponse (Redirect isPerm to) = do + ais <- gets clientActiveIdentities let uri' = to `relativeTo` uri crossSite = uriRegName uri' /= uriRegName uri crossScheme = uriScheme uri' /= uriScheme uri + [fromId,toId] = idAtUri ais <$> [uri,uri'] + crossScope = isJust toId && fromId /= toId warningStr = colour BoldRed - ais <- gets clientActiveIdentities proceed <- (isJust <$>) . lift . runMaybeT $ do when crossSite $ guard <=< (liftIO . promptYN False) $ warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?" when crossScheme $ guard <=< (liftIO . promptYN False) $ warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?" + when crossScope $ guard <=< (liftIO . promptYN False) $ + warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?" when proceed $ do when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks doRequestUri' (redirs + 1) uri' diff --git a/diohscrc.sample b/diohscrc.sample --- a/diohscrc.sample +++ b/diohscrc.sample @@ -1,6 +1,6 @@ #### Sample diohsc configuration: # Copy this to ~/.diohsc/diohscrc and edit it appropriately. -# Each line is a diohsc command to be run at startup. +# Each line is a diohsc command which will be run at startup. ## Proxies @@ -49,6 +49,9 @@ #alias Search 'search query #alias QueueNew at *- add #alias Mpv |mpv --cache-secs 5 - +#alias CS br screen -X register '%s' # copy URI to GNU screen buffer +#alias CX br xsel -i <<< '%s' # copy URI to X selection buffer +#alias GPGImport |gpg --import #alias Read ||- espeak -s 300 --stdin --stdout | aplay #alias BGRead ||- espeak -s 300 --stdin --stdout | aplay &