{-# Language OverloadedStrings, TemplateHaskell #-}
module Client.Commands.Certificate (newCertificateCommand) where
import Client.Commands.Arguments.Spec
import Client.Commands.Docs (netDocs, cmdDoc)
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 :: forall a. Args a (Maybe (Int, String))
keysizeArg = forall r a. Args r a -> Args r (Maybe a)
optionalArg (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall r a. String -> (r -> String -> Maybe a) -> Args r a
tokenArg String
"[keysize]" (forall a b. a -> b -> a
const String -> Maybe Int
parseSize)) (forall r. String -> Args r String
remainingArg String
"[passphrase]"))
parseSize :: String -> Maybe Int
parseSize :: String -> Maybe Int
parseSize String
str =
case forall a. Read a => String -> Maybe a
readMaybe String
str of
Just Int
n | Int
1024 forall a. Ord a => a -> a -> Bool
<= Int
n, Int
n forall a. Ord a => a -> a -> Bool
<= Int
8192 -> forall a. a -> Maybe a
Just Int
n
Maybe Int
_ -> forall a. Maybe a
Nothing
newCertificateCommand :: Command
newCertificateCommand :: Command
newCertificateCommand =
forall a.
NonEmpty Text
-> Args ClientState a -> Text -> CommandImpl a -> Command
Command
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"new-self-signed-cert")
(forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall r. String -> Args r String
simpleToken String
"filename") forall a. Args a (Maybe (Int, String))
keysizeArg)
$(netDocs `cmdDoc` "new-self-signed-cert")
(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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p) ->
do Cipher
cipher <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"No aes128!") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Cipher)
Cipher.getCipherByName String
"aes128"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Cipher
cipher, String -> PemPasswordSupply
PEM.PwStr String
p))
Maybe (Int, String)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
forall key. PublicKey key => X509 -> key -> IO ()
X509.setPublicKey X509
x509 RSAKeyPair
rsa
forall key. KeyPair key => X509 -> key -> Maybe Digest -> IO ()
X509.signX509 X509
x509 RSAKeyPair
rsa forall a. Maybe a
Nothing
ByteString
ctder <- X509 -> IO ByteString
X509.writeDerX509 X509
x509
ByteString
pkder <- X509 -> IO ByteString
getPubKeyDer X509
x509
[[Text]]
msgss <- 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 <- 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try (String -> String -> IO ()
writeFile String
path (String
pem1 forall a. [a] -> [a] -> [a]
++ String
pem2))
case Either IOError ()
res of
Left IOError
e ->
forall (m :: * -> *). Monad m => ClientState -> m CommandResult
commandFailure (ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now Text
"" (String -> Text
Text.pack (forall e. Exception e => e -> String
displayException (IOError
e :: IOError))) ClientState
st)
Right () ->
do let msg :: String
msg = String
"Certificate saved: \x02" forall a. Semigroup a => a -> a -> a
<> String
path forall a. Semigroup a => a -> a -> a
<> String
"\x02"
forall (m :: * -> *). Monad m => ClientState -> m CommandResult
commandSuccess (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ZonedTime -> ClientState -> Text -> ClientState
recordSuccess ZonedTime
now) ClientState
st (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
msgss 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! case Maybe Digest
mb of
Maybe Digest
Nothing -> []
Just Digest
d -> forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack
[ 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))
, 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 = forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr (forall r. PrintfType r => String -> r
printf String
"%02x%s") String
""