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