Certificate.hs

{-# Language OverloadedStrings #-}
{-|
Module      : Client.Commands.Certificate
Description : Certificate management commands
Copyright   : (c) Eric Mertens, 2016-2020
License     : ISC
Maintainer  : emertens@gmail.com
-}

module Client.Commands.Certificate (newCertificateCommand) where

import Client.Commands.Arguments.Spec
import Client.Commands.TabCompletion (noClientTab)
import Client.Commands.Types
import Client.State (recordError, recordSuccess)
import Control.Applicative (liftA2)
import Control.Exception (displayException, try)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as L
import Data.Foldable (foldl')
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), getZonedTime)
import Hookup.OpenSSL (getPubKeyDer)
import OpenSSL.EVP.Cipher qualified as Cipher
import OpenSSL.EVP.Digest qualified as Digest
import OpenSSL.PEM qualified as PEM
import OpenSSL.RSA qualified as RSA
import OpenSSL.X509 qualified as X509
import Text.Printf (printf)
import Text.Read (readMaybe)

keysizeArg :: Args a (Maybe (Int, String))
keysizeArg = optionalArg (liftA2 (,) (tokenArg "[keysize]" (const parseSize)) (remainingArg "[passphrase]"))

parseSize :: String -> Maybe Int
parseSize str =
  case readMaybe str of
    Just n | 1024 <= n, n <= 8192 -> Just n
    _ -> Nothing

newCertificateCommand :: Command
newCertificateCommand =
  Command
    (pure "new-self-signed-cert")
    (liftA2 (,) (simpleToken "filename") keysizeArg)
      "\^BParameters:\^B\n\
      \\n\
      \    filename:   Certificate and private key PEM output\n\
      \    keysize:    Public-key size (default 2048, range 1024-8192)\n\
      \    passphrase: Optional AES-128 private key passphrase\n\
      \\n\
      \\^BDescription:\^B\n\
      \\n\
      \    Generate a new self-signed certificate for network service\n\
      \    identification.\n\
      \\n\
      \\^BExample command:\^B\n\
      \\n\
      \    /new-self-signed-cert /home/me/.glirc/config/my.pem 2048 SeCrEt\n\
      \\n\
      \\^BExample configuration:\^B\n\
      \    servers:\n\
      \      * name:                    \"fn\"\n\
      \        hostname:                \"irc.libera.chat\"\n\
      \        sasl: mechanism:         external\n\
      \        tls:                     yes\n\
      \        tls-client-cert:         \"my.pem\"\n\
      \        tls-client-key-password: \"SeCrEt\"\n"
    (ClientCommand cmdNewCert noClientTab)

cmdNewCert :: ClientCommand (String, Maybe (Int, String))
cmdNewCert st (path, mbExtra) =
 do now <- getZonedTime

    let size =
          case mbExtra of
            Nothing -> 2048
            Just (n,_) -> n
    pass <-
      case mbExtra of
        Just (_,p) | not (null p) ->
         do cipher <- fromMaybe (error "No aes128!") <$> Cipher.getCipherByName "aes128"
            pure (Just (cipher, PEM.PwStr p))
        _ -> pure Nothing

    rsa  <- RSA.generateRSAKey' size 65537
    x509 <- X509.newX509
    X509.setVersion      x509 2
    X509.setSerialNumber x509 1
    X509.setIssuerName   x509 [("CN","glirc")]
    X509.setSubjectName  x509 [("CN","glirc")]
    X509.setNotBefore    x509 (UTCTime (ModifiedJulianDay 40587) 0) -- 1970-01-01
    X509.setNotAfter     x509 (UTCTime (ModifiedJulianDay 77112) 0) -- 2070-01-01
    X509.setPublicKey    x509 rsa
    X509.signX509        x509 rsa Nothing

    ctder <- X509.writeDerX509 x509
    pkder <- getPubKeyDer x509
    msgss <- traverse (getFingerprint ctder pkder) ["sha1", "sha256", "sha512"]

    pem1 <- PEM.writePKCS8PrivateKey rsa pass
    pem2 <- PEM.writeX509 x509
    res  <- try (writeFile path (pem1 ++ pem2))

    case res of
      Left e ->
          commandFailure (recordError now "" (Text.pack (displayException (e :: IOError))) st)
      Right () ->
       do let msg = "Certificate saved: \x02" <> path <> "\x02"
          commandSuccess (foldl' (recordSuccess now) st (concat msgss ++ [Text.pack msg]))

getFingerprint :: L.ByteString -> B.ByteString -> String -> IO [Text]
getFingerprint crt pub name =
 do mb <- Digest.getDigestByName name
    pure $! case mb of
      Nothing -> []
      Just d  -> map Text.pack
        [ printf "CERT %-6s fingerprint: \^C07%s" name (hexString (Digest.digestLBS d crt))
        , printf "SPKI %-6s fingerprint: \^C07%s" name (hexString (Digest.digestBS  d pub))
        ]

hexString :: B.ByteString -> String
hexString = B.foldr (printf "%02x%s") ""