{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Wai.Handler.WarpTLS.Simple (
TLSConfig (..),
tlsConfigResolve,
startWarpServer,
tlsConfigParser,
) where
import Network.Wai (Application)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.WarpTLS qualified as WarpTLS
import Network.Wai.Handler.WarpTLS.Internal qualified as WarpTLS
import Options.Applicative
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath ((</>))
import System.Process (callProcess)
import System.Which (staticWhich)
import Text.Show (Show (..))
opensslBin :: FilePath
opensslBin :: FilePath
opensslBin = $(staticWhich "openssl")
data TLSConfig
=
TLSDisabled
|
TLSAuto
|
TLSExplicit WarpTLS.TLSSettings
instance Show TLSConfig where
show :: TLSConfig -> FilePath
show = \case
TLSConfig
TLSDisabled -> FilePath
"TLSDisabled"
TLSConfig
TLSAuto -> FilePath
"TLSAuto"
TLSExplicit TLSSettings
tlsSettings -> FilePath
"TLSExplicit (user-provided certificates): " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> CertSettings -> FilePath
forall a. Show a => a -> FilePath
Text.Show.show (TLSSettings -> CertSettings
WarpTLS.getCertSettings TLSSettings
tlsSettings)
tlsConfigParser :: Parser TLSConfig
tlsConfigParser :: Parser TLSConfig
tlsConfigParser =
Parser TLSConfig
noHttpsMode Parser TLSConfig -> Parser TLSConfig -> Parser TLSConfig
forall a. Parser a -> Parser a -> Parser a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Parser TLSConfig
tlsExplicitMode Parser TLSConfig -> Parser TLSConfig -> Parser TLSConfig
forall a. Parser a -> Parser a -> Parser a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Parser TLSConfig
defaultMode
where
noHttpsMode :: Parser TLSConfig
noHttpsMode =
TLSConfig -> Mod FlagFields TLSConfig -> Parser TLSConfig
forall a. a -> Mod FlagFields a -> Parser a
flag'
TLSConfig
TLSDisabled
( FilePath -> Mod FlagFields TLSConfig
forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"no-https"
Mod FlagFields TLSConfig
-> Mod FlagFields TLSConfig -> Mod FlagFields TLSConfig
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields TLSConfig
forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Disable HTTPS and run HTTP server only"
)
tlsExplicitMode :: Parser TLSConfig
tlsExplicitMode =
(TLSSettings -> TLSConfig)
-> (FilePath -> TLSSettings) -> FilePath -> TLSConfig
forall a b. (a -> b) -> (FilePath -> a) -> FilePath -> b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TLSSettings -> TLSConfig
TLSExplicit ((FilePath -> TLSSettings) -> FilePath -> TLSConfig)
-> (FilePath -> FilePath -> TLSSettings)
-> FilePath
-> FilePath
-> TLSConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> TLSSettings
WarpTLS.tlsSettings
(FilePath -> FilePath -> TLSConfig)
-> Parser FilePath -> Parser (FilePath -> TLSConfig)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"tls-cert"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"TLS_CERT"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Path to TLS certificate file (requires --tls-key)"
)
Parser (FilePath -> TLSConfig)
-> Parser FilePath -> Parser TLSConfig
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. HasName f => FilePath -> Mod f a
long FilePath
"tls-key"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"TLS_KEY"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: Type -> Type) a. FilePath -> Mod f a
help FilePath
"Path to TLS private key file (requires --tls-cert)"
)
defaultMode :: Parser TLSConfig
defaultMode = TLSConfig -> Parser TLSConfig
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TLSConfig
TLSAuto
tlsConfigResolve :: FilePath -> TLSConfig -> IO (Maybe WarpTLS.TLSSettings)
tlsConfigResolve :: FilePath -> TLSConfig -> IO (Maybe TLSSettings)
tlsConfigResolve FilePath
stateDir = \case
TLSConfig
TLSDisabled -> Maybe TLSSettings -> IO (Maybe TLSSettings)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe TLSSettings
forall a. Maybe a
Nothing
TLSConfig
TLSAuto -> TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just (TLSSettings -> Maybe TLSSettings)
-> IO TLSSettings -> IO (Maybe TLSSettings)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Text -> IO TLSSettings
ensureTLSSettings (FilePath
stateDir FilePath -> ShowS
</> FilePath
"tls") Text
"localhost"
TLSExplicit TLSSettings
tlsSettings -> Maybe TLSSettings -> IO (Maybe TLSSettings)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just TLSSettings
tlsSettings)
ensureTLSSettings :: FilePath -> Text -> IO WarpTLS.TLSSettings
ensureTLSSettings :: FilePath -> Text -> IO TLSSettings
ensureTLSSettings FilePath
certDir Text
hostArg = do
let (FilePath
certPath, FilePath
keyPath) = FilePath -> (FilePath, FilePath)
certPaths FilePath
certDir
Bool
certExists <- FilePath -> IO Bool
doesFileExist FilePath
certPath
Bool
keyExists <- FilePath -> IO Bool
doesFileExist FilePath
keyPath
if Bool
certExists Bool -> Bool -> Bool
&& Bool
keyExists
then do
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Using existing TLS certificates from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
certDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
else do
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn Text
"Generating TLS certificates for HTTPS support..."
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
certDir
FilePath -> Text -> IO ()
generateCertificates FilePath
certDir Text
hostArg
TLSSettings -> IO TLSSettings
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TLSSettings -> IO TLSSettings) -> TLSSettings -> IO TLSSettings
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> TLSSettings
WarpTLS.tlsSettings FilePath
certPath FilePath
keyPath
certPaths :: FilePath -> (FilePath, FilePath)
certPaths :: FilePath -> (FilePath, FilePath)
certPaths FilePath
certDir =
let certPath :: FilePath
certPath = FilePath
certDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/server.crt"
keyPath :: FilePath
keyPath = FilePath
certDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/server.key"
in (FilePath
certPath, FilePath
keyPath)
data CertificateRequest = CertificateRequest
{ CertificateRequest -> CertSubject
certSubject :: CertSubject
, CertificateRequest -> Int
certValidityDays :: Int
, CertificateRequest -> [Text]
certSANHosts :: [Text]
, CertificateRequest -> [Text]
certSANIPs :: [Text]
}
deriving stock (Int -> CertificateRequest -> ShowS
[CertificateRequest] -> ShowS
CertificateRequest -> FilePath
(Int -> CertificateRequest -> ShowS)
-> (CertificateRequest -> FilePath)
-> ([CertificateRequest] -> ShowS)
-> Show CertificateRequest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CertificateRequest -> ShowS
showsPrec :: Int -> CertificateRequest -> ShowS
$cshow :: CertificateRequest -> FilePath
show :: CertificateRequest -> FilePath
$cshowList :: [CertificateRequest] -> ShowS
showList :: [CertificateRequest] -> ShowS
Show)
data CertSubject = CertSubject
{ CertSubject -> Text
certCountry :: Text
, CertSubject -> Text
certState :: Text
, CertSubject -> Text
certLocality :: Text
, CertSubject -> Text
certOrganization :: Text
, CertSubject -> Text
certOrganizationalUnit :: Text
, CertSubject -> Text
certCommonName :: Text
}
deriving stock (Int -> CertSubject -> ShowS
[CertSubject] -> ShowS
CertSubject -> FilePath
(Int -> CertSubject -> ShowS)
-> (CertSubject -> FilePath)
-> ([CertSubject] -> ShowS)
-> Show CertSubject
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CertSubject -> ShowS
showsPrec :: Int -> CertSubject -> ShowS
$cshow :: CertSubject -> FilePath
show :: CertSubject -> FilePath
$cshowList :: [CertSubject] -> ShowS
showList :: [CertSubject] -> ShowS
Show)
defaultCertSubject :: CertSubject
defaultCertSubject :: CertSubject
defaultCertSubject =
CertSubject
{ certCountry :: Text
certCountry = Text
"US"
, certState :: Text
certState = Text
"CA"
, certLocality :: Text
certLocality = Text
"San Francisco"
, certOrganization :: Text
certOrganization = Text
"Vira Development"
, certOrganizationalUnit :: Text
certOrganizationalUnit = Text
"IT Department"
, certCommonName :: Text
certCommonName = Text
"localhost"
}
defaultCertRequest :: Text -> CertificateRequest
defaultCertRequest :: Text -> CertificateRequest
defaultCertRequest Text
hostArg =
CertificateRequest
{ certSubject :: CertSubject
certSubject = CertSubject
defaultCertSubject
, certValidityDays :: Int
certValidityDays = Int
3650
, certSANHosts :: [Text]
certSANHosts = [Text
"localhost", Text
hostArg]
, certSANIPs :: [Text]
certSANIPs =
[ Text
"127.0.0.1"
, Text
"::1"
, Text
"0.0.0.0"
, Text
"192.168.1.1"
, Text
"192.168.1.100"
, Text
"192.168.0.1"
, Text
"192.168.0.100"
, Text
"10.0.0.1"
, Text
"10.0.0.100"
, Text
"172.16.0.1"
, Text
"172.16.0.100"
]
}
generateCertificateWithRequest :: FilePath -> CertificateRequest -> IO ()
generateCertificateWithRequest :: FilePath -> CertificateRequest -> IO ()
generateCertificateWithRequest FilePath
certDir CertificateRequest
request = do
let (FilePath
certPath, FilePath
keyPath) = FilePath -> (FilePath, FilePath)
certPaths FilePath
certDir
FilePath -> [FilePath] -> IO ()
callProcess FilePath
opensslBin [FilePath
"genrsa", FilePath
"-out", FilePath
keyPath, FilePath
"2048"]
let opensslConfig :: Text
opensslConfig = CertificateRequest -> Text
generateOpenSSLConfig CertificateRequest
request
configPath :: FilePath
configPath = FilePath
certDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/openssl.conf"
FilePath -> Text -> IO ()
forall (m :: Type -> Type). MonadIO m => FilePath -> Text -> m ()
writeFileText FilePath
configPath Text
opensslConfig
FilePath -> [FilePath] -> IO ()
callProcess
FilePath
opensslBin
[ FilePath
"req"
, FilePath
"-new"
, FilePath
"-x509"
, FilePath
"-key"
, FilePath
keyPath
, FilePath
"-out"
, FilePath
certPath
, FilePath
"-days"
, Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
Prelude.show CertificateRequest
request.certValidityDays
, FilePath
"-config"
, FilePath
configPath
]
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn Text
"Generated TLS certificates:"
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
" Certificate: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
certPath
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
" Private key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
keyPath
let hostList :: FilePath
hostList = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
forall a. ToString a => a -> FilePath
toString CertificateRequest
request.certSANHosts)
Text -> IO ()
forall (m :: Type -> Type). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
" Valid for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
hostList Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and common local network IPs"
generateOpenSSLConfig :: CertificateRequest -> Text
generateOpenSSLConfig :: CertificateRequest -> Text
generateOpenSSLConfig CertificateRequest
request =
let subject :: CertSubject
subject = CertificateRequest
request.certSubject
dnsEntries :: [Text]
dnsEntries =
(Int -> Text -> Text) -> [Int] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Int
i Text
host -> Text
"DNS." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
Prelude.show Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
host)
[(Int
1 :: Int) ..]
CertificateRequest
request.certSANHosts
ipEntries :: [Text]
ipEntries =
(Int -> Text -> Text) -> [Int] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Int
i Text
ip -> Text
"IP." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
Prelude.show Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ip)
[([Text] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length CertificateRequest
request.certSANHosts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 :: Int) ..]
CertificateRequest
request.certSANIPs
allSANEntries :: [Text]
allSANEntries = [Text]
dnsEntries [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
ipEntries
altNamesSection :: Text
altNamesSection = [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"[alt_names]" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
allSANEntries
in [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
[ Text
"[req]"
, Text
"distinguished_name = req_distinguished_name"
, Text
"req_extensions = v3_req"
, Text
"prompt = no"
, Text
""
, Text
"[req_distinguished_name]"
, Text
"C = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certCountry
, Text
"ST = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certState
, Text
"L = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certLocality
, Text
"O = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certOrganization
, Text
"OU = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certOrganizationalUnit
, Text
"CN = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CertSubject
subject.certCommonName
, Text
""
, Text
"[v3_req]"
, Text
"basicConstraints = CA:FALSE"
, Text
"keyUsage = critical, digitalSignature, keyEncipherment, keyAgreement"
, Text
"extendedKeyUsage = critical, serverAuth, clientAuth"
, Text
"subjectAltName = @alt_names"
, Text
""
, Text
altNamesSection
]
generateCertificates :: FilePath -> Text -> IO ()
generateCertificates :: FilePath -> Text -> IO ()
generateCertificates FilePath
certDir Text
hostArg =
FilePath -> CertificateRequest -> IO ()
generateCertificateWithRequest FilePath
certDir (Text -> CertificateRequest
defaultCertRequest Text
hostArg)
startWarpServer :: Warp.Settings -> FilePath -> TLSConfig -> Application -> IO ()
startWarpServer :: Settings -> FilePath -> TLSConfig -> Application -> IO ()
startWarpServer Settings
settings FilePath
stateDir TLSConfig
tlsConfig Application
app =
FilePath -> TLSConfig -> IO (Maybe TLSSettings)
tlsConfigResolve FilePath
stateDir TLSConfig
tlsConfig IO (Maybe TLSSettings) -> (Maybe TLSSettings -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TLSSettings
Nothing -> Settings -> Application -> IO ()
Warp.runSettings Settings
settings Application
app
Just TLSSettings
tlsSettings -> TLSSettings -> Settings -> Application -> IO ()
WarpTLS.runTLS TLSSettings
tlsSettings Settings
settings Application
app