{-# Language OverloadedStrings, TemplateHaskell #-}
{-|
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.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 = 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 a b c.
(a -> b -> c) -> Ap (Arg a) a -> Ap (Arg a) b -> Ap (Arg a) c
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 ArgsContext (String, Maybe (Int, String))
-> Text
-> CommandImpl (String, Maybe (Int, String))
-> Command
forall a.
NonEmpty Text
-> Args ArgsContext a -> Text -> CommandImpl a -> Command
Command
    (Text -> NonEmpty Text
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"new-self-signed-cert")
    ((String -> Maybe (Int, String) -> (String, Maybe (Int, String)))
-> Ap (Arg ArgsContext) String
-> Ap (Arg ArgsContext) (Maybe (Int, String))
-> Args ArgsContext (String, Maybe (Int, String))
forall a b c.
(a -> b -> c)
-> Ap (Arg ArgsContext) a
-> Ap (Arg ArgsContext) b
-> Ap (Arg ArgsContext) c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (String -> Ap (Arg ArgsContext) String
forall r. String -> Args r String
simpleToken String
"filename") Ap (Arg ArgsContext) (Maybe (Int, String))
forall a. Args a (Maybe (Int, String))
keysizeArg)
    $(netDocs `cmdDoc` "new-self-signed-cert")
    (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 a. [a] -> 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 a. a -> IO a
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 a. a -> IO a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> IO a
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
""