{-# 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
import           Client.Commands.Types
import           Client.State
import           Control.Applicative
import           Control.Exception
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import           Data.Foldable (foldl')
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Time
import           Hookup.OpenSSL (getPubKeyDer)
import qualified OpenSSL.RSA as RSA
import qualified OpenSSL.X509 as X509
import qualified OpenSSL.PEM as PEM
import qualified OpenSSL.EVP.Cipher as Cipher
import qualified OpenSSL.EVP.Digest as Digest
import           Text.Read (readMaybe)
import           Text.Printf (printf)

keysizeArg :: Args a (Maybe (Int, String))
keysizeArg :: Args a (Maybe (Int, String))
keysizeArg = Args a (Int, String) -> Args a (Maybe (Int, String))
forall r a. Args r a -> Args r (Maybe a)
optionalArg ((Int -> String -> (Int, String))
-> Ap (Arg a) Int -> Ap (Arg a) String -> Args a (Int, String)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (String -> (a -> String -> Maybe Int) -> Ap (Arg a) Int
forall r a. String -> (r -> String -> Maybe a) -> Args r a
tokenArg String
"[keysize]" ((String -> Maybe Int) -> a -> String -> Maybe Int
forall a b. a -> b -> a
const String -> Maybe Int
parseSize)) (String -> Ap (Arg a) String
forall r. String -> Args r String
remainingArg String
"[passphrase]"))

parseSize :: String -> Maybe Int
parseSize :: String -> Maybe Int
parseSize String
str =
  case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str of
    Just Int
n | Int
1024 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8192 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    Maybe Int
_ -> Maybe Int
forall a. Maybe a
Nothing

newCertificateCommand :: Command
newCertificateCommand :: Command
newCertificateCommand =
  NonEmpty Text
-> Args ClientState (String, Maybe (Int, String))
-> Text
-> CommandImpl (String, Maybe (Int, String))
-> Command
forall a.
NonEmpty Text
-> Args ClientState a -> Text -> CommandImpl a -> Command
Command
    (Text -> NonEmpty Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"new-self-signed-cert")
    ((String -> Maybe (Int, String) -> (String, Maybe (Int, String)))
-> Ap (Arg ClientState) String
-> Ap (Arg ClientState) (Maybe (Int, String))
-> Args ClientState (String, Maybe (Int, String))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (String -> Ap (Arg ClientState) String
forall r. String -> Args r String
simpleToken String
"filename") Ap (Arg ClientState) (Maybe (Int, String))
forall a. Args a (Maybe (Int, String))
keysizeArg)
      Text
"\^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 (String, Maybe (Int, String))
-> (Bool -> ClientCommand String)
-> CommandImpl (String, Maybe (Int, String))
forall a.
ClientCommand a -> (Bool -> ClientCommand String) -> CommandImpl a
ClientCommand ClientCommand (String, Maybe (Int, String))
cmdNewCert Bool -> ClientCommand String
noClientTab)

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

     let size :: Int
size = case Maybe (Int, String)
mbExtra of
                  Maybe (Int, String)
Nothing -> Int
2048
                  Just (Int
n,String
_) -> Int
n
     Maybe (Cipher, PemPasswordSupply)
pass <- case Maybe (Int, String)
mbExtra of
               Just (Int
_,String
p) | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p) ->
                 do Cipher
cipher <- Cipher -> Maybe Cipher -> Cipher
forall a. a -> Maybe a -> a
fromMaybe (String -> Cipher
forall a. HasCallStack => String -> a
error String
"No aes128!") (Maybe Cipher -> Cipher) -> IO (Maybe Cipher) -> IO Cipher
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Cipher)
Cipher.getCipherByName String
"aes128"
                    Maybe (Cipher, PemPasswordSupply)
-> IO (Maybe (Cipher, PemPasswordSupply))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Cipher, PemPasswordSupply) -> Maybe (Cipher, PemPasswordSupply)
forall a. a -> Maybe a
Just (Cipher
cipher, String -> PemPasswordSupply
PEM.PwStr String
p))
               Maybe (Int, String)
_ -> Maybe (Cipher, PemPasswordSupply)
-> IO (Maybe (Cipher, PemPasswordSupply))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Cipher, PemPasswordSupply)
forall a. Maybe a
Nothing

     RSAKeyPair
rsa  <- Int -> Int -> IO RSAKeyPair
RSA.generateRSAKey' Int
size Int
65537
     X509
x509 <- IO X509
X509.newX509
     X509 -> Int -> IO ()
X509.setVersion      X509
x509 Int
2
     X509 -> Integer -> IO ()
X509.setSerialNumber X509
x509 Integer
1
     X509 -> [(String, String)] -> IO ()
X509.setIssuerName   X509
x509 [(String
"CN",String
"glirc")]
     X509 -> [(String, String)] -> IO ()
X509.setSubjectName  X509
x509 [(String
"CN",String
"glirc")]
     X509 -> UTCTime -> IO ()
X509.setNotBefore    X509
x509 (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
40587) DiffTime
0) -- 1970-01-01
     X509 -> UTCTime -> IO ()
X509.setNotAfter     X509
x509 (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
77112) DiffTime
0) -- 2070-01-01
     X509 -> RSAKeyPair -> IO ()
forall key. PublicKey key => X509 -> key -> IO ()
X509.setPublicKey    X509
x509 RSAKeyPair
rsa
     X509 -> RSAKeyPair -> Maybe Digest -> IO ()
forall key. KeyPair key => X509 -> key -> Maybe Digest -> IO ()
X509.signX509        X509
x509 RSAKeyPair
rsa Maybe Digest
forall a. Maybe a
Nothing

     ByteString
ctder <- X509 -> IO ByteString
X509.writeDerX509 X509
x509
     ByteString
pkder <- X509 -> IO ByteString
getPubKeyDer X509
x509
     [[Text]]
msgss <- (String -> IO [Text]) -> [String] -> IO [[Text]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ByteString -> ByteString -> String -> IO [Text]
getFingerprint ByteString
ctder ByteString
pkder) [String
"sha1", String
"sha256", String
"sha512"]

     String
pem1 <- RSAKeyPair -> Maybe (Cipher, PemPasswordSupply) -> IO String
forall key.
KeyPair key =>
key -> Maybe (Cipher, PemPasswordSupply) -> IO String
PEM.writePKCS8PrivateKey RSAKeyPair
rsa Maybe (Cipher, PemPasswordSupply)
pass
     String
pem2 <- X509 -> IO String
PEM.writeX509 X509
x509
     Either IOError ()
res  <- IO () -> IO (Either IOError ())
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> String -> IO ()
writeFile String
path (String
pem1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pem2))

     case Either IOError ()
res of
       Left IOError
e ->
        ClientState -> IO CommandResult
forall (m :: * -> *). Monad m => ClientState -> m CommandResult
commandFailure (ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now Text
"" (String -> Text
Text.pack (IOError -> String
forall e. Exception e => e -> String
displayException (IOError
e :: IOError))) ClientState
st)
       Right () ->
        do let msg :: String
msg = String
"Certificate saved: \x02" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\x02"
           ClientState -> IO CommandResult
forall (m :: * -> *). Monad m => ClientState -> m CommandResult
commandSuccess ((ClientState -> Text -> ClientState)
-> ClientState -> [Text] -> ClientState
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ZonedTime -> ClientState -> Text -> ClientState
recordSuccess ZonedTime
now) ClientState
st ([[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
msgss [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [String -> Text
Text.pack String
msg]))

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

hexString :: B.ByteString -> String
hexString :: ByteString -> String
hexString = (Word8 -> String -> String) -> String -> ByteString -> String
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr (String -> Word8 -> String -> String
forall r. PrintfType r => String -> r
printf String
"%02x%s") String
""