{-# 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 = 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) -- 1970-01-01
    X509 -> UTCTime -> IO ()
X509.setNotAfter     X509
x509 (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
77112) DiffTime
0) -- 2070-01-01
    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
""