Identity.hs

   1 -- This file is part of htalkat
   2 -- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE LambdaCase        #-}
  12 {-# LANGUAGE OverloadedStrings #-}
  13
  14 module Identity where
  15
  16 import           Network.TLS              (Credential, credentialLoadX509)
  17 import           System.FilePath          ((<.>), (</>))
  18
  19 import           Data.ASN1.BinaryEncoding (DER (..))
  20 import           Data.ASN1.Encoding       (encodeASN1')
  21 import           Data.ASN1.OID
  22 import           Data.ASN1.Types          (ASN1Object (..))
  23 import           Data.ASN1.Types.String   (ASN1StringEncoding (UTF8))
  24 import           Data.Hourglass
  25 import           Data.PEM
  26 import           Data.X509                as X
  27
  28 #ifndef WINDOWS
  29 import           System.Posix.Files       (ownerReadMode, ownerWriteMode,
  30                                            setFileMode, unionFileModes)
  31 #endif
  32
  33 import qualified Crypto.PubKey.Ed25519    as Ed25519
  34 import qualified Data.ByteArray           as BA
  35 import qualified Data.ByteString          as BS
  36 import qualified Data.Text                as TS
  37 import qualified Data.Text.Encoding       as TS
  38
  39 import           Certificate
  40 import           Fingerprint
  41 import           Host
  42 import           Mundanities
  43 import           Petname
  44 import           Prompt
  45 import           User
  46 import           Util
  47
  48 #if !(MIN_VERSION_base(4,11,0))
  49 import           Data.Semigroup
  50 #endif
  51
  52 data IdentityType = IdConnect | IdListen deriving Eq
  53
  54 loadIdentity :: FilePath -> IdentityType -> IO (Maybe Credential)
  55 loadIdentity ddir tp = do
  56     let base = ddir </> "id"
  57         certpath = base <> (if tp == IdConnect then "-connect" else "-listen") <.> "crt"
  58         keypath = base <.> "key"
  59     ignoreIOErrAlt $ eitherToMaybe <$> credentialLoadX509 certpath keypath
  60
  61 saveIdentity :: FilePath -> PrivKey -> CertificateChain -> CertificateChain -> IO ()
  62 saveIdentity ddir secKey connectChain listenChain = do
  63     let base = ddir </> "id"
  64         connectCertpath = base <> "-connect" <.> "crt"
  65         listenCertpath = base <> "-listen" <.> "crt"
  66         keypath = base <.> "key"
  67     ignoreIOErr $ do
  68         writeChain connectCertpath connectChain
  69         writeChain listenCertpath listenChain
  70         BS.writeFile keypath . pemWriteBS . PEM "PRIVATE KEY" [] . encodeDER $ secKey
  71 #ifndef WINDOWS
  72         setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
  73 #endif
  74     where
  75     writeChain certpath chain =
  76         let CertificateChainRaw rawCerts = encodeCertificateChain chain
  77             chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts
  78         in BS.writeFile certpath $ BS.intercalate "\n" chainPEMs
  79     encodeDER :: ASN1Object o => o -> BS.ByteString
  80     encodeDER = encodeASN1' DER . (`toASN1` [])
  81
  82 createOrShowIdentity :: FilePath -> Maybe String -> IO ()
  83 createOrShowIdentity ddir mCN =
  84     mapM (loadIdentity ddir) [IdConnect,IdListen] >>= \case
  85         [Just (connectChain,_), Just (_,_)]
  86                 | Just cert <- takeTailCert connectChain
  87                 , Nothing <- mCN -> do
  88             mapM_ putStrLn
  89                 [ "Your fingerprint: talkat:" <> showFingerprint (spkiFingerprint cert)
  90                 , "Your public name: " <> certCN cert
  91                 ]
  92         [Just (_,key), Just (listenChain,_)]
  93                 | Just cn <- mCN ->
  94             case key of
  95                 PrivKeyEd25519 secKey -> do
  96                     connectChain' <- generateSelfSigned secKey cn
  97                     saveIdentity ddir key connectChain' listenChain
  98                 _ -> putStrLn "Error: Can't regenerate non-ED25519 key!"
  99         _ -> do
 100             putStrLn "Generating new identity."
 101             secKey <- Ed25519.generateSecretKey
 102             let promptCN = do
 103                     putStrLn "Enter a public name for this identity (can be blank)."
 104                     putStrLn "This will be shown to anyone you connect to, but not to incoming callers."
 105                     putStrLn "(You can reset this name later with 'htalkat i NEW_NAME')"
 106                     promptLine "Public name: "
 107             cn <- maybe promptCN pure mCN
 108             connectChain <- generateSelfSigned secKey cn
 109             listenChain <- generateSelfSigned secKey ""
 110             saveIdentity ddir (PrivKeyEd25519 secKey) connectChain listenChain
 111             let Just cert = takeTailCert connectChain
 112                 fp = spkiFingerprint cert
 113             putStrLn $ "Your fingerprint: talkat:" <> showFingerprint fp
 114             writeName ddir (User fp (parseHost "localhost")) $ Named "self"
 115
 116 generateSelfSigned :: Ed25519.SecretKey -> String -> IO CertificateChain
 117 generateSelfSigned secKey cn =
 118     let dn = DistinguishedName [(getObjectID DnCommonName,
 119             ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
 120         sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
 121         -- RFC5280: To indicate that a certificate has no well-defined expiration
 122         -- date, the notAfter SHOULD be assigned the GeneralizedTime value of
 123         -- 99991231235959Z.
 124         notAfterMax :: DateTime
 125         notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0)
 126
 127         -- RFC5280 has no corresponding prescription for notBefore.
 128         -- 19500101000000Z seems the canonical choice, but it seems to get
 129         -- loaded as 2050 for some reason. So we use 1970.
 130         notBeforeMin :: DateTime
 131         notBeforeMin = DateTime (Date 1970 January 1) (TimeOfDay 0 0 0 0)
 132
 133         cert pubKey = X.Certificate
 134             { certVersion = 2
 135             , certSerial = 0
 136             , certSignatureAlg = sigAlg
 137             , certIssuerDN = dn
 138             , certSubjectDN = dn
 139             , certValidity = (timeConvert notBeforeMin, timeConvert notAfterMax)
 140             , certPubKey = pubKey
 141             , certExtensions = Extensions Nothing
 142             }
 143     in do
 144         let pubKey = Ed25519.toPublic secKey
 145         let signed = fst $ objectToSignedExact
 146                 (\b -> (BS.pack . BA.unpack $ Ed25519.sign secKey pubKey b, sigAlg, ()))
 147                 (cert $ PubKeyEd25519 pubKey)
 148         pure $ CertificateChain [signed]