diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Sridhar Ratnakumar + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/Network/Wai/Handler/WarpTLS/Simple.hs b/src/Network/Wai/Handler/WarpTLS/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Handler/WarpTLS/Simple.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Wai.Handler.WarpTLS.Simple ( + -- * Type + TLSConfig (..), + + -- * Function + tlsConfigResolve, + startWarpServer, + + -- * CLI parser + 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 (..)) + +{- | Path to the `openssl` executable + +This should be available in the PATH, thanks to Nix and `which` library. +-} +opensslBin :: FilePath +opensslBin = $(staticWhich "openssl") + +-- | TLS configuration with HTTPS enabled by default +data TLSConfig + = -- | No TLS - run HTTP only (explicit) + TLSDisabled + | -- | TLS with auto-generated certificates (default) + TLSAuto + | -- | TLS with user-provided certificate and key files + TLSExplicit WarpTLS.TLSSettings + +instance Show TLSConfig where + show = \case + TLSDisabled -> "TLSDisabled" + TLSAuto -> "TLSAuto" + TLSExplicit tlsSettings -> "TLSExplicit (user-provided certificates): " <> Text.Show.show (WarpTLS.getCertSettings tlsSettings) + +-- | Parser for TLS configuration with HTTPS enabled by default +tlsConfigParser :: Parser TLSConfig +tlsConfigParser = + noHttpsMode <|> tlsExplicitMode <|> defaultMode + where + noHttpsMode = + flag' + TLSDisabled + ( long "no-https" + <> help "Disable HTTPS and run HTTP server only" + ) + + tlsExplicitMode = + fmap TLSExplicit . WarpTLS.tlsSettings + <$> strOption + ( long "tls-cert" + <> metavar "TLS_CERT" + <> help "Path to TLS certificate file (requires --tls-key)" + ) + <*> strOption + ( long "tls-key" + <> metavar "TLS_KEY" + <> help "Path to TLS private key file (requires --tls-cert)" + ) + + -- Default to auto-generation (HTTPS enabled by default) + defaultMode = pure TLSAuto + +tlsConfigResolve :: FilePath -> TLSConfig -> IO (Maybe WarpTLS.TLSSettings) +tlsConfigResolve stateDir = \case + TLSDisabled -> pure Nothing + TLSAuto -> Just <$> ensureTLSSettings (stateDir "tls") "localhost" + TLSExplicit tlsSettings -> pure (Just tlsSettings) + +{- | Ensure TLS certificates exist for auto-generation mode +Returns TLSSettings configured with the certificate and key file paths +-} +ensureTLSSettings :: FilePath -> Text -> IO WarpTLS.TLSSettings +ensureTLSSettings certDir hostArg = do + let (certPath, keyPath) = certPaths certDir + + certExists <- doesFileExist certPath + keyExists <- doesFileExist keyPath + + if certExists && keyExists + then do + putTextLn $ "Using existing TLS certificates from " <> toText certDir <> "/" + else do + putTextLn "Generating TLS certificates for HTTPS support..." + createDirectoryIfMissing True certDir + generateCertificates certDir hostArg + + pure $ WarpTLS.tlsSettings certPath keyPath + +-- | Helper function to construct certificate and key file paths from a directory +certPaths :: FilePath -> (FilePath, FilePath) +certPaths certDir = + let certPath = certDir <> "/server.crt" + keyPath = certDir <> "/server.key" + in (certPath, keyPath) + +-- | High-level certificate request configuration +data CertificateRequest = CertificateRequest + { certSubject :: CertSubject + , certValidityDays :: Int + , certSANHosts :: [Text] -- Additional SAN hostnames + , certSANIPs :: [Text] -- Additional SAN IP addresses + } + deriving stock (Show) + +-- | Certificate subject information for self-signed certificates +data CertSubject = CertSubject + { certCountry :: Text + , certState :: Text + , certLocality :: Text + , certOrganization :: Text + , certOrganizationalUnit :: Text + , certCommonName :: Text + } + deriving stock (Show) + +-- | Default certificate subject for development +defaultCertSubject :: CertSubject +defaultCertSubject = + CertSubject + { certCountry = "US" + , certState = "CA" + , certLocality = "San Francisco" + , certOrganization = "Vira Development" + , certOrganizationalUnit = "IT Department" + , certCommonName = "localhost" + } + +-- | Default certificate request for local development +defaultCertRequest :: Text -> CertificateRequest +defaultCertRequest hostArg = + CertificateRequest + { certSubject = defaultCertSubject + , certValidityDays = 3650 -- 10 years + , certSANHosts = ["localhost", hostArg] + , certSANIPs = + [ "127.0.0.1" + , "::1" + , "0.0.0.0" + , "192.168.1.1" + , "192.168.1.100" + , "192.168.0.1" + , "192.168.0.100" + , "10.0.0.1" + , "10.0.0.100" + , "172.16.0.1" + , "172.16.0.100" + ] + } + +-- | Generate a self-signed certificate using a certificate request +generateCertificateWithRequest :: FilePath -> CertificateRequest -> IO () +generateCertificateWithRequest certDir request = do + let (certPath, keyPath) = certPaths certDir + + -- Generate private key + callProcess opensslBin ["genrsa", "-out", keyPath, "2048"] + + -- Create OpenSSL config + let opensslConfig = generateOpenSSLConfig request + configPath = certDir <> "/openssl.conf" + + writeFileText configPath opensslConfig + + -- Generate self-signed certificate + callProcess + opensslBin + [ "req" + , "-new" + , "-x509" + , "-key" + , keyPath + , "-out" + , certPath + , "-days" + , Prelude.show request.certValidityDays + , "-config" + , configPath + ] + + putTextLn "Generated TLS certificates:" + putTextLn $ " Certificate: " <> toText certPath + putTextLn $ " Private key: " <> toText keyPath + let hostList = intercalate ", " (map toString request.certSANHosts) + putTextLn $ " Valid for: " <> toText hostList <> " and common local network IPs" + +-- | Generate OpenSSL configuration from a certificate request +generateOpenSSLConfig :: CertificateRequest -> Text +generateOpenSSLConfig request = + let subject = request.certSubject + dnsEntries = + zipWith + (\i host -> "DNS." <> Prelude.show i <> " = " <> host) + [(1 :: Int) ..] + request.certSANHosts + ipEntries = + zipWith + (\i ip -> "IP." <> Prelude.show i <> " = " <> ip) + [(length request.certSANHosts + 1 :: Int) ..] + request.certSANIPs + allSANEntries = dnsEntries <> ipEntries + altNamesSection = unlines $ "[alt_names]" : allSANEntries + in unlines + [ "[req]" + , "distinguished_name = req_distinguished_name" + , "req_extensions = v3_req" + , "prompt = no" + , "" + , "[req_distinguished_name]" + , "C = " <> subject.certCountry + , "ST = " <> subject.certState + , "L = " <> subject.certLocality + , "O = " <> subject.certOrganization + , "OU = " <> subject.certOrganizationalUnit + , "CN = " <> subject.certCommonName + , "" + , "[v3_req]" + , "basicConstraints = CA:FALSE" + , "keyUsage = critical, digitalSignature, keyEncipherment, keyAgreement" + , "extendedKeyUsage = critical, serverAuth, clientAuth" + , "subjectAltName = @alt_names" + , "" + , altNamesSection + ] + +-- | Generate self-signed certificates with proper SAN for local network access (simplified API) +generateCertificates :: FilePath -> Text -> IO () +generateCertificates certDir hostArg = + generateCertificateWithRequest certDir (defaultCertRequest hostArg) + +-- | Start a Warp server with optional TLS +startWarpServer :: Warp.Settings -> FilePath -> TLSConfig -> Application -> IO () +startWarpServer settings stateDir tlsConfig app = + tlsConfigResolve stateDir tlsConfig >>= \case + Nothing -> Warp.runSettings settings app + Just tlsSettings -> WarpTLS.runTLS tlsSettings settings app diff --git a/warp-tls-simple.cabal b/warp-tls-simple.cabal new file mode 100644 --- /dev/null +++ b/warp-tls-simple.cabal @@ -0,0 +1,71 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: warp-tls-simple +version: 0.1.0.0 +synopsis: Simple TLS configuration for Warp +description: Simplified TLS setup and certificate generation for Warp servers +category: Web +author: Sridhar Ratnakumar +maintainer: srid@srid.ca +copyright: 2025 Juspay +license: MIT +license-file: LICENSE +build-type: Simple + +library + exposed-modules: + Network.Wai.Handler.WarpTLS.Simple + other-modules: + Paths_warp_tls_simple + autogen-modules: + Paths_warp_tls_simple + hs-source-dirs: + src + default-extensions: + DataKinds + DeriveDataTypeable + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + ExplicitForAll + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoStarIsType + NumericUnderscores + OverloadedStrings + ScopedTypeVariables + StrictData + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -optP-Wno-nonportable-include-path -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wunused-foralls -fprint-explicit-foralls -fprint-explicit-kinds + build-depends: + base ==4.* + , directory + , filepath + , optparse-applicative + , process + , relude >=1.0 + , text + , wai + , warp + , warp-tls + , which + mixins: + base hiding (Prelude) + , relude (Relude as Prelude, Relude.Container.One) + , relude + default-language: GHC2021