{-# Language OverloadedStrings #-}
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)
X509 -> UTCTime -> IO ()
X509.setNotAfter X509
x509 (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
77112) DiffTime
0)
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
""