content: {-# LANGUAGE DeriveGeneric #-}
  --
  {-# LANGUAGE TupleSections #-}
  
  -- | Configuration for generating X509 certificates
  --
  -- Users are expected to provide configuration (from file or by hand) and use
  -- 'fromConfiguration' to turn them into description.
  -- Then, full description can be turned into certificates via 'genCertificate'
  --
  -- Configuration --fromConfiguration--> Description --genCertificate--> Certificate
  module Cardano.X509.Configuration
      ( -- * Configuration for Certificates
        TLSConfiguration (..)
      , ServerConfiguration (..)
      , CertConfiguration (..)
      , DirConfiguration (..)
  
        -- * Description of Certificates
      , CertDescription (..)
  
        -- * Effectful Functions
      , ConfigurationKey (..)
      , ErrInvalidTLSConfiguration
      , ErrInvalidExpiryDays
      , fromConfiguration
      , decodeConfigFile
      , genCertificate
      ) where
  
  import Prelude
  
  import Control.Monad
      ( when
      , (>=>)
      )
  import Control.Monad.Catch
      ( Exception
      , MonadThrow (..)
      )
  import Control.Monad.IO.Class
      ( MonadIO (..)
      )
  import Crypto.PubKey.RSA
      ( PrivateKey
      , PublicKey
      )
  import Data.Aeson
      ( FromJSON (parseJSON)
      , KeyValue ((.=))
      , ToJSON (toJSON)
      , Value
      , object
      , withObject
      , (.:)
      )
  import Data.ASN1.OID
      ( OIDable (..)
      )
  import Data.Hourglass
      ( Minutes (..)
      , Period (..)
      , dateAddPeriod
      , timeAdd
      )
  import Data.List.NonEmpty
      ( NonEmpty
      )
  import Data.String
      ( fromString
      )
  import Data.X509
      ( DistinguishedName (..)
      , DnElement (..)
      , ExtAuthorityKeyId (..)
      , ExtBasicConstraints (..)
      , ExtExtendedKeyUsage (..)
      , ExtKeyUsage (..)
      , ExtKeyUsageFlag (..)
      , ExtKeyUsagePurpose (..)
      , ExtSubjectAltName (..)
      , ExtSubjectKeyId (..)
      , ExtensionRaw
      , Extensions (..)
      , PubKey (..)
      , SignedCertificate
      , extensionEncode
      , hashDN
      )
  import Data.X509.Extra
      ( parseSAN
      , signAlgRSA256
      , signCertificate
      )
  import Data.X509.Validation
      ( ValidationChecks (..)
      , defaultChecks
      )
  import Data.Yaml
      ( decodeFileEither
      , parseEither
      )
  import GHC.Generics
      ( Generic
      )
  import Time.System
      ( dateCurrent
      )
  import Time.Types
      ( DateTime (..)
      )
  
  import qualified Data.Aeson.Key as Aeson
  import qualified Data.Aeson.KeyMap as Aeson
  import qualified Data.Aeson.Types as Aeson
  import qualified Data.List.NonEmpty as NE
  import qualified Data.X509 as X509
  
  --
  -- Configuration of Certificates
  --
  
  -- | Foreign Configuration, pulled from within a .yaml file
  data TLSConfiguration = TLSConfiguration
      { tlsCa :: CertConfiguration
      , tlsServer :: ServerConfiguration
      , tlsClients :: [CertConfiguration]
      }
      deriving (Generic, Show, Eq)
  
  instance FromJSON TLSConfiguration where
      parseJSON = withObject "TLSConfiguration" $ \o ->
          TLSConfiguration <$> o .: "ca" <*> o .: "server" <*> o .: "clients"
  
  instance ToJSON TLSConfiguration where
      toJSON conf =
          object
              [ "ca" .= tlsCa conf
              , "server" .= tlsServer conf
              , "clients" .= tlsClients conf
              ]
  
  -- | Output directories configuration
  data DirConfiguration = DirConfiguration
      { outDirServer :: FilePath
      , outDirClients :: FilePath
      , outDirCA :: Maybe FilePath
      }
      deriving (Generic, Show, Eq)
  
  -- | Foreign Certificate Configuration
  data CertConfiguration = CertConfiguration
      { certOrganization :: String
      , certCommonName :: String
      , certExpiryDays :: Int
      }
      deriving (Generic, Show, Eq)
  
  instance FromJSON CertConfiguration where
      parseJSON = withObject "CertConfiguration" $ \o ->
          CertConfiguration
              <$> o .: "organization"
              <*> o .: "commonName"
              <*> o .: "expiryDays"
  
  instance ToJSON CertConfiguration where
      toJSON certconf =
          object
              [ "organization" .= certOrganization certconf
              , "commonName" .= certCommonName certconf
              , "expiryDays" .= certExpiryDays certconf
              ]
  
  -- | Foreign Server Certificate Configuration (SANS extra options)
  data ServerConfiguration = ServerConfiguration
      { serverConfiguration :: CertConfiguration
      , serverAltNames :: NonEmpty String
      }
      deriving (Generic, Show, Eq)
  
  -- NOTE We keep the declaration structure 'flat' such that servers config
  -- are simply client config with an extra field 'altDNS'
  instance FromJSON ServerConfiguration where
      parseJSON v =
          ServerConfiguration
              <$> ( ( withObject "CertConfiguration" $ \o ->
                          CertConfiguration
                              <$> o .: "organization"
                              <*> o .: "commonName"
                              <*> o .: "expiryDays"
                    )
                      v
                  )
              <*> ((withObject "ServerConfiguration" $ \o -> o .: "altDNS") v)
  
  instance ToJSON ServerConfiguration where
      toJSON conf =
          object
              [ "organization" .= certOrganization (serverConfiguration conf)
              , "commonName" .= certCommonName (serverConfiguration conf)
              , "expiryDays" .= certExpiryDays (serverConfiguration conf)
              , "altDNS" .= serverAltNames conf
              ]
  
  --
  -- Description of Certificates
  --
  
  -- | Internal full-representation of a certificate
  data CertDescription m pub priv outdir = CertDescription
      { certConfiguration :: CertConfiguration
      , certSerial :: Int
      , certExtensions :: [ExtensionRaw]
      , certIssuer :: DistinguishedName
      , certSubject :: DistinguishedName
      , certGenKeys :: m (pub, priv)
      , certSigningKey :: priv
      , certOutDir :: outdir
      , certFilename :: String
      , certChecks :: ValidationChecks
      }
  
  --
  -- Effectful Functions
  --
  
  -- | Type-alias for signature readability
  newtype ConfigurationKey = ConfigurationKey
      { getConfigurationKey :: String
      }
      deriving (Eq, Show)
  
  newtype ErrInvalidExpiryDays
      = ErrInvalidExpiryDays String
      deriving (Show)
  
  instance Exception ErrInvalidExpiryDays
  
  newtype ErrInvalidTLSConfiguration
      = ErrInvalidTLSConfiguration String
      deriving (Show)
  
  instance Exception ErrInvalidTLSConfiguration
  
  -- | Describe a list of certificates to generate & sign from a foreign config
  --
  -- Description can then be used with @genCertificate@ to obtain corresponding
  -- certificate
  fromConfiguration
      :: (Applicative m)
      => TLSConfiguration
      -- ^ Foreign TLS configuration / setup
      -> DirConfiguration
      -- ^ Output directories configuration
      -> m (pub, priv)
      -- ^ Key pair generator
      -> (pub, priv)
      -- ^ Initial / Root key pair
      -> ( CertDescription m pub priv (Maybe String)
         , [CertDescription m pub priv String]
         )
      -- ^ PKI description matching provided conf, fst = CA, snd = server & clients
  fromConfiguration tlsConf dirConf genKeys (caPub, caPriv) =
      let
          caDN = mkDistinguishedName (tlsCa tlsConf)
  
          caConfig =
              CertDescription
                  { certConfiguration = tlsCa tlsConf
                  , certSerial = 1
                  , certExtensions = caExtensionsV3 caDN
                  , certIssuer = caDN
                  , certSubject = caDN
                  , certGenKeys = pure (caPub, caPriv)
                  , certSigningKey = caPriv
                  , certOutDir = outDirCA dirConf
                  , certFilename = "ca"
                  , certChecks = defaultChecks
                  }
  
          ServerConfiguration tlsServer' serverAltDNS = tlsServer tlsConf
          svDN = mkDistinguishedName tlsServer'
          svConfig =
              CertDescription
                  { certConfiguration = tlsServer'
                  , certSerial = 2
                  , certExtensions = svExtensionsV3 svDN caDN serverAltDNS
                  , certIssuer = caDN
                  , certSubject = svDN
                  , certGenKeys = genKeys
                  , certSigningKey = caPriv
                  , certOutDir = outDirServer dirConf
                  , certFilename = "server"
                  , certChecks = defaultChecks
                  }
  
          clConfigs = forEach (tlsClients tlsConf) $ \(i, tlsClient) ->
              let
                  clDN = mkDistinguishedName tlsClient
                  suffix = if i == 0 then "" else "_" <> show i
              in
                  CertDescription
                      { certConfiguration = tlsClient
                      , certSerial = 3 + i
                      , certExtensions = clExtensionsV3 clDN caDN
                      , certIssuer = caDN
                      , certSubject = clDN
                      , certGenKeys = genKeys
                      , certSigningKey = caPriv
                      , certOutDir = outDirClients dirConf
                      , certFilename = "client" <> suffix
                      , certChecks = defaultChecks{checkFQHN = False}
                      }
      in
          (caConfig, svConfig : clConfigs)
  
  -- | Decode a configuration file (.yaml). The expected file structure is:
  --     <configuration-key>:
  --       tls:
  --         ca: ...
  --         server: ...
  --         clients: ...
  --
  -- where the 'configuration-key' represents the target environment (dev, test,
  -- bench, etc.).
  decodeConfigFile
      :: (MonadIO m, MonadThrow m)
      => ConfigurationKey
      -- ^ Target configuration Key
      -> FilePath
      -- ^ Target configuration file
      -> m TLSConfiguration
  decodeConfigFile (ConfigurationKey cKey) filepath =
      either throwInv pure . parseEither parser =<< decodeFileMonad filepath
    where
      errMsg key = "property '" <> key <> "' " <> "not found in configuration file."
  
      decodeFileMonad :: (MonadIO m, MonadThrow m) => FilePath -> m Value
      decodeFileMonad =
          (liftIO . decodeFileEither) >=> either (throwInv . show) pure
  
      throwInv :: MonadThrow m => String -> m a
      throwInv = throwM . ErrInvalidTLSConfiguration
  
      parser :: Value -> Aeson.Parser TLSConfiguration
      parser = withObject "TLS Configuration" (parseK cKey >=> parseK "tls")
  
      parseK :: FromJSON a => String -> Aeson.Object -> Aeson.Parser a
      parseK key =
          maybe (fail $ errMsg key) parseJSON
              . Aeson.lookup (Aeson.fromString key)
  
  -- | Generate & sign a certificate from a certificate description
  genCertificate
      :: CertDescription IO PublicKey PrivateKey filename
      -> IO (PrivateKey, SignedCertificate)
  genCertificate desc = do
      ((pub, priv), now) <- (,) <$> (certGenKeys desc) <*> dateCurrent
  
      let conf = certConfiguration desc
  
      when (certExpiryDays conf <= 0)
          $ throwM
          $ ErrInvalidExpiryDays "expiry days should be a positive integer"
  
      let cert =
              X509.Certificate
                  { X509.certVersion = 2
                  , X509.certSerial = fromIntegral (certSerial desc)
                  , X509.certSignatureAlg = signAlgRSA256
                  , X509.certValidity =
                      (addMinutes (-1) now, addDays (certExpiryDays conf) now)
                  , X509.certPubKey = PubKeyRSA pub
                  , X509.certExtensions = Extensions (Just $ certExtensions desc)
                  , X509.certIssuerDN = certIssuer desc
                  , X509.certSubjectDN = certSubject desc
                  }
  
      (priv,) <$> signCertificate (certSigningKey desc) cert
    where
      addDays :: Int -> DateTime -> DateTime
      addDays n time@(DateTime date _) =
          time{dtDate = dateAddPeriod date (mempty{periodDays = n})}
  
      addMinutes :: Int -> DateTime -> DateTime
      addMinutes n time =
          timeAdd time (Minutes $ fromIntegral n)
  
  --
  -- Internals
  --
  
  caExtensionsV3 :: DistinguishedName -> [ExtensionRaw]
  caExtensionsV3 dn =
      let
          keyUsage = ExtKeyUsage [KeyUsage_keyCertSign, KeyUsage_cRLSign]
          basicConstraints = ExtBasicConstraints True (Just 0)
          subjectKeyId = ExtSubjectKeyId (hashDN dn)
          authorityKeyId = ExtAuthorityKeyId (hashDN dn)
      in
          [ extensionEncode True keyUsage
          , extensionEncode True basicConstraints
          , extensionEncode False subjectKeyId
          , extensionEncode False authorityKeyId
          ]
  
  usExtensionsV3
      :: ExtKeyUsagePurpose
      -> DistinguishedName
      -> DistinguishedName
      -> [ExtensionRaw]
  usExtensionsV3 purpose subDN issDN =
      let
          keyUsage =
              ExtKeyUsage [KeyUsage_digitalSignature, KeyUsage_keyEncipherment]
          basicConstraints = ExtBasicConstraints False Nothing
          subjectKeyId = ExtSubjectKeyId (hashDN subDN)
          authorityKeyId = ExtAuthorityKeyId (hashDN issDN)
          extendedKeyUsage = ExtExtendedKeyUsage [purpose]
      in
          [ extensionEncode True keyUsage
          , extensionEncode False extendedKeyUsage
          , extensionEncode False basicConstraints
          , extensionEncode False subjectKeyId
          , extensionEncode False authorityKeyId
          ]
  
  svExtensionsV3
      :: DistinguishedName
      -> DistinguishedName
      -> NonEmpty String
      -> [ExtensionRaw]
  svExtensionsV3 subDN issDN altNames =
      let
          subjectAltName =
              ExtSubjectAltName $ map parseSAN (NE.toList altNames)
      in
          extensionEncode False subjectAltName
              : usExtensionsV3 KeyUsagePurpose_ServerAuth subDN issDN
  
  clExtensionsV3
      :: DistinguishedName -> DistinguishedName -> [ExtensionRaw]
  clExtensionsV3 =
      usExtensionsV3 KeyUsagePurpose_ClientAuth
  
  forEach :: [a] -> ((Int, a) -> b) -> [b]
  forEach xs fn =
      zipWith (curry fn) [0 .. (length xs - 1)] xs
  
  mkDistinguishedName :: CertConfiguration -> DistinguishedName
  mkDistinguishedName conf =
      DistinguishedName
          [ (getObjectID DnOrganization, fromString $ certOrganization conf)
          , (getObjectID DnCommonName, fromString $ certCommonName conf)
          ]
  