From 76d3433cb5cb83206ffeae20f352338748c7f7dc Mon Sep 17 00:00:00 2001 From: mbays Date: Sun, 8 Aug 2021 00:00:00 +0000 Subject: [PATCH] optionally create Ed25519 client certificates --- ClientCert.hs | 75 ++++++++++++++++++++++++----------------------------------- Command.hs | 8 +++++-- Identity.hs | 12 +++++----- diohsc.1.md | 7 +++--- diohsc.cabal | 1 + diohsc.hs | 9 +++++-- 6 files changed, 54 insertions(+), 58 deletions(-) diff --git a/ClientCert.hs b/ClientCert.hs index 4cc9622..b1068df 100644 --- a/ClientCert.hs +++ b/ClientCert.hs @@ -19,7 +19,6 @@ 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 @@ -35,6 +34,9 @@ import Safe import System.FilePath import Time.System +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 @@ -112,56 +114,41 @@ notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0) 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 index 35bd9c0..3cd3e64 100644 --- a/Command.hs +++ b/Command.hs @@ -314,7 +314,7 @@ helpOn s = "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 @@ helpOn s = , "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 @@ helpOn s = , "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/Identity.hs b/Identity.hs index 68876a0..469b286 100644 --- a/Identity.hs +++ b/Identity.hs @@ -45,18 +45,18 @@ showIdentityName ansi name = applyIf ansi (withColourStr Green) $ 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." + putStrLn "Creating a new 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 +72,7 @@ getIdentityRequesting ansi idsPath = runMaybeT $ do 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/diohsc.1.md b/diohsc.1.md index b1e8849..a970718 100644 --- a/diohsc.1.md +++ b/diohsc.1.md @@ -108,8 +108,10 @@ diohsc understands. : 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, @@ -126,9 +128,6 @@ PAGER # 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. You should have obtained a copy of the licence as the file COPYING. diff --git a/diohsc.cabal b/diohsc.cabal index 841fe05..c835985 100644 --- a/diohsc.cabal +++ b/diohsc.cabal @@ -95,6 +95,7 @@ executable diohsc 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 && <0.5, network-uri >=2.6.3.0 && <2.8, diff --git a/diohsc.hs b/diohsc.hs index 914c34c..1212052 100644 --- a/diohsc.hs +++ b/diohsc.hs @@ -57,6 +57,7 @@ import ANSIColour import ActiveIdentities import Alias import qualified BStack +import ClientCert (KeyType (..)) import Command import CommandLine import GeminiProtocol @@ -871,10 +872,14 @@ handleCommandLine 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 -- 2.11.4.GIT