htalkat-0.1.1: Identity.hs

-- This file is part of htalkat
-- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Identity where

import           Network.TLS              (Credential, credentialLoadX509)
import           System.FilePath          ((<.>), (</>))

import           Data.ASN1.BinaryEncoding (DER (..))
import           Data.ASN1.Encoding       (encodeASN1')
import           Data.ASN1.OID
import           Data.ASN1.Types          (ASN1Object (..))
import           Data.ASN1.Types.String   (ASN1StringEncoding (UTF8))
import           Data.Hourglass
import           Data.PEM
import           Data.X509                as X

#ifndef WINDOWS
import           System.Posix.Files       (ownerReadMode, ownerWriteMode,
                                           setFileMode, unionFileModes)
#endif

import qualified Crypto.PubKey.Ed25519    as Ed25519
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           Certificate
import           Fingerprint
import           Host
import           Mundanities
import           Petname
import           Prompt
import           User
import           Util

data IdentityType = IdConnect | IdListen deriving Eq

loadIdentity :: FilePath -> IdentityType -> IO (Maybe Credential)
loadIdentity ddir tp = do
    let base = ddir </> "id"
        certpath = base <> (if tp == IdConnect then "-connect" else "-listen") <.> "crt"
        keypath = base <.> "key"
    ignoreIOErrAlt $ eitherToMaybe <$> credentialLoadX509 certpath keypath

saveIdentity :: FilePath -> PrivKey -> CertificateChain -> CertificateChain -> IO ()
saveIdentity ddir secKey connectChain listenChain = do
    let base = ddir </> "id"
        connectCertpath = base <> "-connect" <.> "crt"
        listenCertpath = base <> "-listen" <.> "crt"
        keypath = base <.> "key"
    ignoreIOErr $ do
        writeChain connectCertpath connectChain
        writeChain listenCertpath listenChain
        BS.writeFile keypath . pemWriteBS . PEM "PRIVATE KEY" [] . encodeDER $ secKey
#ifndef WINDOWS
        setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
#endif
    where
    writeChain certpath chain =
        let CertificateChainRaw rawCerts = encodeCertificateChain chain
            chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts
        in BS.writeFile certpath $ BS.intercalate "\n" chainPEMs
    encodeDER :: ASN1Object o => o -> BS.ByteString
    encodeDER = encodeASN1' DER . (`toASN1` [])

createOrShowIdentity :: FilePath -> Maybe String -> IO ()
createOrShowIdentity ddir mCN =
    mapM (loadIdentity ddir) [IdConnect,IdListen] >>= \case
        [Just (connectChain,_), Just (_,_)]
                | Just cert <- takeTailCert connectChain
                , Nothing <- mCN -> do
            mapM_ putStrLn
                [ "Your fingerprint: talkat:" <> showFingerprint (spkiFingerprint cert)
                , "Your public name: " <> certCN cert
                ]
        [Just (_,key), Just (listenChain,_)]
                | Just cn <- mCN ->
            case key of
                PrivKeyEd25519 secKey -> do
                    connectChain' <- generateSelfSigned secKey cn
                    saveIdentity ddir key connectChain' listenChain
                _ -> putStrLn "Error: Can't regenerate non-ED25519 key!"
        _ -> do
            putStrLn "Generating new identity."
            secKey <- Ed25519.generateSecretKey
            let promptCN = do
                    putStrLn "Enter a public name for this identity (can be blank)."
                    putStrLn "This will be shown to anyone you connect to, and only to them."
                    putStrLn "(You can change this later by rerunning this command)"
                    promptLine "Public name: "
            cn <- maybe promptCN pure mCN
            connectChain <- generateSelfSigned secKey cn
            listenChain <- generateSelfSigned secKey ""
            saveIdentity ddir (PrivKeyEd25519 secKey) connectChain listenChain
            let Just cert = takeTailCert connectChain
                fp = spkiFingerprint cert
            putStrLn $ "Your fingerprint: talkat:" <> showFingerprint fp
            writeName ddir (User fp (parseHost "localhost")) $ Named "self"

generateSelfSigned :: Ed25519.SecretKey -> String -> IO CertificateChain
generateSelfSigned secKey cn =
    let dn = DistinguishedName [(getObjectID DnCommonName,
            ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
        sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
        -- RFC5280: To indicate that a certificate has no well-defined expiration
        -- date, the notAfter SHOULD be assigned the GeneralizedTime value of
        -- 99991231235959Z.
        notAfterMax :: DateTime
        notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0)

        -- RFC5280 has no corresponding prescription for notBefore.
        -- 19500101000000Z seems the canonical choice, but it seems to get
        -- loaded as 2050 for some reason. So we use 1970.
        notBeforeMin :: DateTime
        notBeforeMin = DateTime (Date 1970 January 1) (TimeOfDay 0 0 0 0)

        cert pubKey = X.Certificate
            { certVersion = 2
            , certSerial = 0
            , certSignatureAlg = sigAlg
            , certIssuerDN = dn
            , certSubjectDN = dn
            , certValidity = (timeConvert notBeforeMin, timeConvert notAfterMax)
            , certPubKey = pubKey
            , certExtensions = Extensions Nothing
            }
    in do
        let pubKey = Ed25519.toPublic secKey
        let signed = fst $ objectToSignedExact
                (\b -> (BS.pack . BA.unpack $ Ed25519.sign secKey pubKey b, sigAlg, ()))
                (cert $ PubKeyEd25519 pubKey)
        pure $ CertificateChain [signed]