mighttpd2 3.4.6 → 4.0.0

raw patch · 16 files changed

+541/−210 lines, 16 filesdep +base16-bytestringdep +dhalldep +quicdep ~basedep ~wai-http2-extradep ~warpPVP ok

version bump matches the API change (PVP)

Dependencies added: base16-bytestring, dhall, quic, split, text, time-manager, unliftio, warp-quic

Dependency ranges changed: base, wai-http2-extra, warp, warp-tls

API changes (from Hackage documentation)

Files

• Program/Mighty.hs +2/−0
• Program/Mighty/Config.hs +137/−58
• Program/Mighty/Dhall/Option.hs +16/−0
• Program/Mighty/Parser.hs +1/−4
• Program/Mighty/Process.hs +3/−7
• Program/Mighty/Report.hs +16/−37
• Program/Mighty/Resource.hs +6/−7
• Program/Mighty/Route.hs +10/−4
• Program/Mighty/Types.hs +12/−0
• cbits/setcap.c +53/−0
• conf/example.conf +16/−7
• mighttpd2.cabal +46/−12
• src/Mighty.hs +29/−13
• src/Server.hs +149/−56
• src/WaiApp.hs +3/−2
• test/ConfigSpec.hs +42/−3

@@ -12,6 +12,7 @@   , module Program.Mighty.Process   , module Program.Mighty.Resource   , module Program.Mighty.Signal+  , module Program.Mighty.Types   ) where  import Program.Mighty.ByteString@@ -23,3 +24,4 @@ import Program.Mighty.Resource import Program.Mighty.Route import Program.Mighty.Signal+import Program.Mighty.Types

@@ -1,87 +1,153 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module Program.Mighty.Config (   -- * Parsing a configuration file.     parseOption+#ifdef DHALL+  , parseOptionDhall+#else+  , Natural+#endif   -- * Creating 'Option'.   , defaultOption   -- * Types   , Option(..)   ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative hiding (many,optional,(<|>))-#endif-import Program.Mighty.Parser+import Data.List.Split (splitOn) import Text.Parsec import Text.Parsec.ByteString.Lazy+#ifdef DHALL+import Data.String (fromString)+import qualified Data.Text as T+import Dhall(Generic, Natural, input, auto, FromDhall)+import qualified Program.Mighty.Dhall.Option as Do +#else+import Program.Mighty.Types+#endif++import Program.Mighty.Parser+ ---------------------------------------------------------------- +data Option = Option {+    opt_port :: Natural+  , opt_host :: String+  , opt_debug_mode :: Bool+  , opt_user  :: String+  , opt_group :: String+  , opt_pid_file    :: FilePath+  , opt_report_file :: FilePath+  , opt_logging :: Bool+  , opt_log_file :: FilePath+  , opt_log_file_size :: Natural+  , opt_log_backup_number :: Natural+  , opt_index_file :: FilePath+  , opt_index_cgi  :: FilePath+  , opt_status_file_dir :: FilePath+  , opt_connection_timeout :: Natural+  , opt_proxy_timeout      :: Natural+  , opt_fd_cache_duration  :: Natural+  , opt_service :: Natural+  , opt_tls_port :: Natural+  , opt_tls_cert_file   :: FilePath+  , opt_tls_chain_files :: FilePath+  , opt_tls_key_file    :: FilePath+  , opt_quic_port :: Natural+  , opt_quic_addr :: [String]+  , opt_quic_debug_dir :: Maybe FilePath+  , opt_quic_qlog_dir  :: Maybe FilePath+  , opt_server_name :: String+  , opt_routing_file :: Maybe String+#ifdef DHALL+} deriving (Eq, Show, Generic)+#else+} deriving (Eq, Show)+#endif++#ifdef DHALL+instance FromDhall Option+#endif+ -- | Getting a default 'Option'.-defaultOption :: String -- ^ A default server name (e.g. \"Mighttpd/3.0.0\")-              -> Option-defaultOption svrnm = Option {+defaultOption :: Option+defaultOption = Option {     opt_port = 8080   , opt_host = "*"   , opt_debug_mode = True-  , opt_user = "root"+  , opt_user  = "root"   , opt_group = "root"-  , opt_pid_file = "/var/run/mighty.pid"+  , opt_pid_file    = "/var/run/mighty.pid"   , opt_report_file = "/tmp/mighty_report"   , opt_logging = True   , opt_log_file = "/var/log/mighty"   , opt_log_file_size = 16777216   , opt_log_backup_number = 10   , opt_index_file = "index.html"-  , opt_index_cgi = "index.cgi"+  , opt_index_cgi  = "index.cgi"   , opt_status_file_dir = "/usr/local/share/mighty/status"   , opt_connection_timeout = 30-  , opt_proxy_timeout = 0-  , opt_fd_cache_duration = 10-  , opt_server_name = svrnm-  , opt_routing_file = Nothing+  , opt_proxy_timeout      = 0+  , opt_fd_cache_duration  = 10+  , opt_service = 0   , opt_tls_port = 443-  , opt_tls_cert_file = "cert.pem"+  , opt_tls_cert_file   = "cert.pem"   , opt_tls_chain_files = "chain.pem"-  , opt_tls_key_file = "privkey.pem"-  , opt_service = 0+  , opt_tls_key_file    = "privkey.pem"+  , opt_quic_port = 443+  , opt_quic_addr = ["127.0.0.1"]+  , opt_quic_debug_dir = Nothing+  , opt_quic_qlog_dir  = Nothing+  , opt_server_name = "Dummy"+  , opt_routing_file = Nothing } -data Option = Option {-    opt_port :: !Int-  , opt_host :: !String-  , opt_debug_mode :: !Bool-  , opt_user :: !String-  , opt_group :: !String-  , opt_pid_file :: !FilePath-  , opt_report_file :: !FilePath-  , opt_logging :: !Bool-  , opt_log_file :: !FilePath-  , opt_log_file_size :: !Int-  , opt_log_backup_number :: !Int-  , opt_index_file :: !FilePath-  , opt_index_cgi  :: !FilePath-  , opt_status_file_dir :: !FilePath-  , opt_connection_timeout :: !Int-  , opt_proxy_timeout :: !Int-  , opt_fd_cache_duration :: !Int-  , opt_server_name :: !String-  , opt_routing_file :: !(Maybe FilePath)-  , opt_tls_port :: !Int-  , opt_tls_cert_file :: !FilePath-  , opt_tls_chain_files :: !FilePath-  , opt_tls_key_file :: !FilePath-  , opt_service :: !Int-} deriving (Eq,Show)- ----------------------------------------------------------------- -- | Parsing a configuration file to get an 'Option'.-parseOption :: FilePath -> String -> IO Option-parseOption file svrnm = makeOpt (defaultOption svrnm) <$> parseConfig file+parseOption :: FilePath -> IO Option+parseOption file = makeOpt defaultOption <$> parseConfig file +#ifdef DHALL+parseOptionDhall :: FilePath -> IO Option+parseOptionDhall = fmap optionFromDhall . input auto . fromString++optionFromDhall :: Do.Option -> Option+optionFromDhall o = Option+  { opt_port = Do.port o+  , opt_host = T.unpack $ Do.host o+  , opt_debug_mode = Do.debugMode o+  , opt_user  = T.unpack $ Do.user o+  , opt_group = T.unpack $ Do.group o+  , opt_pid_file    = T.unpack $ Do.pidFile o+  , opt_report_file = T.unpack $ Do.reportFile o+  , opt_logging = Do.logging o+  , opt_log_file = T.unpack $ Do.logFile o+  , opt_log_file_size = Do.logFileSize o+  , opt_log_backup_number = Do.logBackupNumber o+  , opt_index_file = T.unpack $ Do.indexFile o+  , opt_index_cgi  = T.unpack $ Do.indexCgi o+  , opt_status_file_dir = T.unpack $ Do.statusFileDir o+  , opt_connection_timeout = Do.connectionTimeout o+  , opt_proxy_timeout      = Do.proxyTimeout o+  , opt_fd_cache_duration  = Do.fdCacheDuration o+  , opt_service = Do.service o+  , opt_tls_port = Do.tlsPort o+  , opt_tls_cert_file   = T.unpack $ Do.tlsCertFile o+  , opt_tls_chain_files = T.unpack $ Do.tlsChainFiles o+  , opt_tls_key_file    = T.unpack $ Do.tlsKeyFile o+  , opt_quic_addr = T.unpack <$> Do.quicAddr o+  , opt_quic_port = Do.quicPort o+  , opt_quic_debug_dir = T.unpack <$> Do.quicDebugDir o+  , opt_quic_qlog_dir  = T.unpack <$> Do.quicQlogDir o+  , opt_server_name = "Dummy"+  , opt_routing_file = Nothing+}+#endif+ ----------------------------------------------------------------  makeOpt :: Option -> [Conf] -> Option@@ -103,13 +169,17 @@   , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout   , opt_proxy_timeout      = get "Proxy_Timeout" opt_proxy_timeout   , opt_fd_cache_duration  = get "Fd_Cache_Duration" opt_fd_cache_duration-  , opt_server_name        = get "Server_Name" opt_server_name-  , opt_routing_file       = Nothing+  , opt_service            = get "Service" opt_service   , opt_tls_port           = get "Tls_Port" opt_tls_port   , opt_tls_cert_file      = get "Tls_Cert_File" opt_tls_cert_file   , opt_tls_chain_files    = get "Tls_Chain_Files" opt_tls_chain_files   , opt_tls_key_file       = get "Tls_Key_File" opt_tls_key_file-  , opt_service            = get "Service" opt_service+  , opt_quic_addr          = get "Quic_Addr" opt_quic_addr+  , opt_quic_port          = get "Quic_Port" opt_quic_port+  , opt_quic_debug_dir     = get "Quic_Debug_Dir" opt_quic_debug_dir+  , opt_quic_qlog_dir      = get "Quic_Qlog_Dir" opt_quic_qlog_dir+  , opt_server_name        = "Dummy"+  , opt_routing_file       = Nothing   }   where     get k func = maybe (func def) fromConf $ lookup k conf@@ -118,13 +188,13 @@  type Conf = (String, ConfValue) -data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show)+data ConfValue = CV_Natural Natural | CV_Bool Bool | CV_String String deriving (Eq,Show)  class FromConf a where     fromConf :: ConfValue -> a -instance FromConf Int where-    fromConf (CV_Int n) = n+instance FromConf Natural where+    fromConf (CV_Natural n) = n     fromConf _ = error "fromConf int"  instance FromConf Bool where@@ -135,6 +205,15 @@     fromConf (CV_String s) = s     fromConf _ = error "fromConf string" +instance FromConf (Maybe String) where+    fromConf (CV_String "") = Nothing+    fromConf (CV_String s)  = Just s+    fromConf _ = error "fromConf string"++instance FromConf [String] where+    fromConf (CV_String s)  = splitOn "," s+    fromConf _ = error "fromConf string"+ ----------------------------------------------------------------  parseConfig :: FilePath -> IO [Conf]@@ -157,15 +236,15 @@ sep = () <$ char ':' *> spcs  value :: Parser ConfValue-value = choice [try cv_int, try cv_bool, cv_string]+value = choice [try cv_natural, try cv_bool, cv_string]  -- Trailing should be included in try to allow IP addresses.-cv_int :: Parser ConfValue-cv_int = CV_Int . read <$> many1 digit <* trailing+cv_natural :: Parser ConfValue+cv_natural = CV_Natural . read <$> many1 digit <* trailing  cv_bool :: Parser ConfValue cv_bool = CV_Bool True  <$ string "Yes" <* trailing <|>-          CV_Bool False <$ string "No"   <* trailing+          CV_Bool False <$ string "No"  <* trailing  cv_string :: Parser ConfValue cv_string = CV_String <$> many (noneOf " \t\n") <* trailing

@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE CPP                #-}++module Program.Mighty.Dhall.Option where++#ifdef DHALL+import Dhall.TH++Dhall.TH.makeHaskellTypes+    [ SingleConstructor "Option" "MakeOption" "./Program/Mighty/Dhall/Option.dhall"+    ]+#endif

@@ -14,14 +14,11 @@   , comment   ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative hiding (many,(<|>))-#endif-import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy+import UnliftIO.Exception  -- $setup -- >>> import Data.Either

@@ -1,13 +1,10 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Program.Mighty.Process (     getMightyPid   ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS@@ -17,7 +14,6 @@ import Data.Conduit.Process import Data.Function import Data.List-import Data.Ord import System.Posix.Types  ----------------------------------------------------------------@@ -65,7 +61,7 @@     candidates = map head                $ filter (\xs -> length xs == 1) -- master is alone                $ groupBy ((==) `on` ppid)-               $ sortBy (comparing ppid) rest+               $ sortOn ppid rest   deleteAloneChild :: [PsResult] -> [PsResult]@@ -79,7 +75,7 @@  -- | Getting the process id of a running Mighty. getMightyPid :: IO [ProcessID]-getMightyPid = (map pid . findParent) <$> runPS+getMightyPid = map pid . findParent <$> runPS  ---------------------------------------------------------------- 

@@ -1,10 +1,10 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Program.Mighty.Report (     Reporter   , initReporter-  , finReporter   , report   , reportDo   , warpHandler@@ -14,8 +14,6 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif-import Control.Exception-import qualified Control.Exception as E (catch) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS@@ -23,65 +21,46 @@ import GHC.IO.Exception (IOErrorType(..)) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest)-import Network.Wai.Handler.Warp.Internal (TimeoutThread(..)) import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID)+import UnliftIO.Exception  import Program.Mighty.ByteString  data Method = FileOnly | FileAndStdout deriving Eq-data Reporter = Reporter Method Handle+data Reporter = Reporter Method FilePath -initReporter :: Bool -> FilePath -> IO (Either SomeException Reporter)-initReporter debug reportFile = try $ Reporter method <$> openFile reportFile AppendMode+initReporter :: Bool -> FilePath -> Reporter+initReporter debug reportFile = Reporter method reportFile   where     method       | debug     = FileAndStdout       | otherwise = FileOnly -finReporter :: Reporter -> IO ()-finReporter (Reporter _ rpthdl) = hClose rpthdl- report :: Reporter -> ByteString -> IO ()-report (Reporter method rpthdl) msg = handle (\(SomeException _) -> return ()) $ do+report (Reporter method reportFile) msg = handle (\(SomeException _) -> return ()) $ do     pid <- BS.pack . show <$> getProcessID     tm <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S"     let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"]-    BS.hPutStr rpthdl logmsg-    hFlush rpthdl+    BS.appendFile reportFile logmsg     when (method == FileAndStdout) $ BS.putStr logmsg  ----------------------------------------------------------------  reportDo :: Reporter -> IO () -> IO ()-reportDo rpt act = act `E.catch` warpHandler rpt Nothing+reportDo rpt act = act `catchAny` warpHandler rpt Nothing  ----------------------------------------------------------------  warpHandler :: Reporter -> Maybe Request -> SomeException -> IO ()-warpHandler rpt _ e = throwIO e `catches` handlers-  where-    handlers = [Handler ah, Handler th, Handler ih, Handler oh, Handler sh]-    ah :: AsyncException -> IO ()-    ah ThreadKilled = norecode-    ah x            = recode x-    th :: TimeoutThread -> IO ()-    th TimeoutThread = norecode-    ih :: InvalidRequest -> IO ()-    ih _ = norecode-    oh :: IOException -> IO ()-    oh x-      | et `elem` ignEts = norecode-      | otherwise        = recode x-      where-        et = ioeGetErrorType x-        ignEts = [ResourceVanished, InvalidArgument]-    sh :: SomeException -> IO ()-    sh x = recode x-    norecode = return ()-    recode :: Exception e => e -> IO ()-    recode   = report rpt . bshow+warpHandler rpt _ se+  | Just (_ :: InvalidRequest) <- fromException se = return ()+  | Just (e :: IOException)    <- fromException se =+        if ioeGetErrorType e `elem` [ResourceVanished,InvalidArgument]+        then return ()+        else report rpt $ bshow se+  | otherwise = report rpt $ bshow se  ---------------------------------------------------------------- 

@@ -6,12 +6,8 @@   , unlimit   ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Exception-import Control.Monad import System.Posix+import UnliftIO.Exception  ---------------------------------------------------------------- @@ -24,12 +20,15 @@ -- | Setting user and group. setGroupUser :: String -- ^ User              -> String -- ^ Group-             -> IO ()+             -> IO Bool setGroupUser user group = do     root <- amIrootUser-    when root $ do+    if root then do         getGroupEntryForName group >>= setGroupID . groupID         getUserEntryForName user >>= setUserID . userID+        return True+      else+        return False  ---------------------------------------------------------------- 

@@ -1,5 +1,6 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  module Program.Mighty.Route (   -- * Paring a routing file@@ -19,13 +20,13 @@   , writeRouteDBRef   ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative hiding (many,(<|>))-#endif import Control.Monad import Data.ByteString import qualified Data.ByteString.Char8 as BS import Data.IORef+#ifdef DHALL+import GHC.Natural (Natural)+#endif import Network.Wai.Application.Classic import Text.Parsec import Text.Parsec.ByteString.Lazy@@ -39,7 +40,12 @@ -- | A physical path in a file system. type Dst      = Path type Domain   = ByteString+#ifdef DHALL+type Port     = Natural+#else type Port     = Int+#endif+ data Block    = Block [Domain] [Route] deriving (Eq,Show) data Route    = RouteFile     Src Dst               | RouteRedirect Src Dst

@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}++module Program.Mighty.Types (Natural, naturalToInt) where++#ifdef DHALL+import GHC.Natural (Natural, naturalToInt)+#else+type Natural = Int++naturalToInt :: Natural -> Int+naturalToInt = id+#endif

@@ -0,0 +1,53 @@+#if defined(__linux__)+#include <linux/securebits.h>+#include <signal.h>+#include <stdio.h>+#include <string.h>+#include <sys/capability.h>+#include <sys/prctl.h>+#include <sys/syscall.h>+#include <sys/types.h>+#include <unistd.h>++#include "Rts.h"++void set_capabilities (uint32_t cap) {+  cap_user_header_t header = malloc(sizeof(*header));+  header->version = _LINUX_CAPABILITY_VERSION_3;+  header->pid = 0;++  cap_user_data_t data = malloc(sizeof(*data));+  data->effective   = cap;+  data->permitted   = cap;+  data->inheritable = 0;++  capset(header,data);++  free(header);+  free(data);+}++void handler(int signum) {+  uint32_t cap = 1 << CAP_NET_BIND_SERVICE;+  set_capabilities (cap);+}++void FlagDefaultsHook () {+  if (geteuid() == 0) {+    prctl(PR_SET_SECUREBITS, SECBIT_KEEP_CAPS, 0L, 0L, 0L);++    struct sigaction sa;+    memset(&sa, 0, sizeof(sa));+    sa.sa_handler = handler;+    sa.sa_flags = SA_RESTART;+    sigaction(SIGUSR1, &sa, NULL);+  }+}++void send_signal (int tid, int sig) {+  int tgid = getpid();+  syscall(SYS_tgkill, tgid, tid, sig);+}+#else+void send_signal (int tid, int sig) {}+#endif

@@ -3,14 +3,15 @@ # IP address or "*" Host: * Debug_Mode: Yes # Yes or No-# If available, "nobody" is much more secure for User:.+# If available, "nobody" is much more secure for User: User: root-# If available, "nobody" is much more secure for Group:.+# If available, "nobody" is much more secure for Group: Group: root Pid_File: /var/run/mighty.pid Report_File: /tmp/mighty_report Logging: Yes # Yes or No-Log_File: /var/log/mighty # The directory must be writable by User:+# The directory must be writable by User:+Log_File: /var/log/mighty Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html@@ -19,11 +20,19 @@ Connection_Timeout: 30 # seconds Proxy_Timeout: 0 # seconds, 0 is default of http-client, ie 30 seconds Fd_Cache_Duration: 10 # seconds-# Server_Name: Mighttpd/3.x.y+# 0 is HTTP only+# 1 is HTTPS only+# 2 is for both HTTP and HTTPs+# 3 is for HTTP, HTTPs and QUIC(HTTP/3)+Service: 0 Tls_Port: 443-Tls_Cert_File: cert.pem # should change this with an absolute path+# should change this with an absolute path+Tls_Cert_File: cert.pem # should change this with comma-separated absolute paths Tls_Chain_Files: chain.pem-# Currently, Tls_Key_File must not be encrypted.+# Currently, Tls_Key_File must not be encrypted Tls_Key_File: privkey.pem # should change this with an absolute path-Service: 0 # 0 is HTTP only, 1 is HTTPS only, 2 is both+Quic_Addr: 127.0.0.1,::1+Quic_Port: 443+#Quic_Debug_Dir: /var/log/mighy/quic-debug/+#Quic_Qlog_Dir: /varlog/mighty/qlog/

@@ -1,5 +1,5 @@ Name:                   mighttpd2-Version:                3.4.6+Version:                4.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -9,7 +9,7 @@                         files and CGI on WAI/warp.                         Reverse proxy functionality is also provided                         to connect web applications behind.-Homepage:               http://www.mew.org/~kazu/proj/mighttpd/+Homepage:               https://kazu-yamamoto.github.io/mighttpd2/ Category:               Network, Web Cabal-Version:          >= 1.10 Build-Type:             Simple@@ -17,9 +17,17 @@ Data-Files:             example.conf example.route  Flag tls-  Description:          Support http over tls (https).+  Description:          Support HTTP over TLS (HTTPS).   Default:              False +Flag quic+  Description:          Support HTTP over QUIC (HTTP/3).+  Default:              False++Flag dhall+  Description:          Support Dhall+  Default:              False+ Library   Default-Language:     Haskell2010   GHC-Options:          -Wall@@ -33,6 +41,8 @@                         Program.Mighty.Resource                         Program.Mighty.Route                         Program.Mighty.Signal+                        Program.Mighty.Dhall.Option+                        Program.Mighty.Types   Build-Depends:        base >= 4.9 && < 5                       , array                       , async@@ -50,14 +60,20 @@                       , parsec >= 3                       , resourcet                       , streaming-commons+                      , split+                      , text                       , unix                       , unix-time                       , unordered-containers                       , wai >= 3.2 && < 3.3                       , wai-app-file-cgi >= 3.1.9 && < 3.2-                      , warp >= 3.3 && < 3.4+                      , warp >= 3.3.15 && < 3.4+                      , unliftio   if impl(ghc >= 8)     Default-Extensions:  Strict StrictData+  if flag(dhall)+    Cpp-Options:        -DDHALL+    Build-Depends:      dhall  Executable mighty   Default-Language:     Haskell2010@@ -68,7 +84,18 @@     Cpp-Options:        -DHTTP_OVER_TLS     Build-Depends:      async                       , tls-session-manager >= 0.0.2.0-  Build-Depends:        base >= 4.0 && < 5+  if flag(quic)+    Cpp-Options:        -DHTTP_OVER_QUIC+    Build-Depends:      async+                      , base16-bytestring+    if os(linux)+      C-sources:        cbits/setcap.c+      Cpp-Options:      -DDROP_EXCEPT_BIND++  if flag(dhall)+    Cpp-Options:        -DDHALL+    Build-Depends:      dhall+  Build-Depends:        base >= 4.9 && < 5                       , bytestring                       , directory                       , filepath@@ -81,14 +108,18 @@                       , transformers                       , unix                       , streaming-commons+                      , time-manager                       , wai >= 3.2 && < 3.3                       , wai-app-file-cgi >= 3.1.9 && < 3.2                       , wai-logger >= 2.3.0-                      , warp >= 3.3 && < 3.4-                      , wai-http2-extra >= 0.1+                      , warp >= 3.3.13 && < 3.4+                      , wai-http2-extra >= 0.1.3   if flag(tls)     Build-Depends:      tls-                      , warp-tls >= 3.2.7 && < 3.3+                      , warp-tls >= 3.2.12 && < 3.4+  if flag(quic)+    Build-Depends:      quic+                      , warp-quic   Other-Modules:        Server                         WaiApp                         Paths_mighttpd2@@ -100,7 +131,7 @@   HS-Source-Dirs:       utils, src   Main-Is:              mkindex.hs   GHC-Options:          -Wall-  Build-Depends:        base >= 4 && < 5+  Build-Depends:        base >= 4.9 && < 5                       , directory                       , old-locale                       , time@@ -111,7 +142,7 @@   HS-Source-Dirs:       utils, src   Main-Is:              mightyctl.hs   GHC-Options:          -Wall-  Build-Depends:        base >= 4 && < 5+  Build-Depends:        base >= 4.9 && < 5                       , unix                       , mighttpd2   if impl(ghc >= 8)@@ -124,15 +155,18 @@   Type:                 exitcode-stdio-1.0   Other-Modules:        ConfigSpec                         RouteSpec-  Build-Depends:        base >= 4 && < 5+  Build-Depends:        base >= 4.9 && < 5                       , hspec >= 1.3                       , mighttpd2                       , http-client >= 0.5   if flag(tls)     Build-Depends:      tls-                      , warp-tls >= 3.2.7 && < 3.3+                      , warp-tls >= 3.2.12 && < 3.4   if impl(ghc >= 8)     Default-Extensions:  Strict StrictData+  if flag(dhall)+    Cpp-Options:        -DDHALL+    Build-Depends:      dhall  Source-Repository head   Type:                 git

@@ -1,10 +1,15 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Main where -#ifndef HTTP_OVER_TLS+#ifndef HTTP_OVER_QUIC import Control.Monad (when) #endif++#ifdef DHALL+import Data.List (isSuffixOf)+#endif import Data.Version (showVersion) import Network.Wai.Application.Classic hiding ((</>)) import System.Directory (getCurrentDirectory)@@ -34,8 +39,8 @@     checkTLS opt     let reportFile = reportFileName opt         debug = opt_debug_mode opt-    rpt <- initReporter debug reportFile >>= checkReporter reportFile-    let run = server opt rpt route+        rpt = initReporter debug reportFile+        run = server opt rpt route     if debug then run else background opt run   where     getOptRoute = getArgs >>= eachCase@@ -43,8 +48,9 @@     eachCase args       | n == 0 = do           root <- amIrootUser-          let opt | root      = (defaultOption svrnm) { opt_port = 80 }-                  | otherwise = defaultOption svrnm+          let opt0 = defaultOption { opt_server_name = svrnm }+          let opt | root      = opt0 { opt_port = 80 }+                  | otherwise = opt0           dir <- getCurrentDirectory           let dst = fromString . addTrailingPathSeparator $ dir               route = [Block ["*"] [RouteFile "/" dst]]@@ -52,9 +58,18 @@       | n == 2 = do           let config_file = args !! 0           routing_file <- getAbsoluteFile (args !! 1)-          opt   <- parseOption config_file svrnm+#ifdef DHALL+          let isDhall = ".dhall" `Data.List.isSuffixOf` config_file+          opt   <- if isDhall+                   then parseOptionDhall config_file+                   else parseOption config_file+#else+          opt   <- parseOption config_file+#endif           route <- parseRoute  routing_file defaultDomain defaultPort-          let opt' = opt {opt_routing_file = Just routing_file}+          let opt' = opt { opt_routing_file = Just routing_file+                         , opt_server_name = svrnm+                         }           return (opt',route)       | otherwise = do           hPutStrLn stderr "Usage: mighty"@@ -67,13 +82,14 @@       | otherwise       = do           dir <- getCurrentDirectory           return $ dir </> normalise file-    checkReporter _          (Right rpt) = return rpt-    checkReporter reportFile (Left e)    = do-        hPutStrLn stderr $ reportFile ++ " is not writable"-        hPrint stderr e-        exitFailure #ifdef HTTP_OVER_TLS+#ifdef HTTP_OVER_QUIC     checkTLS _ = return ()+#else+    checkTLS opt = when (opt_service opt > 2) $ do+        hPutStrLn stderr "This mighty does not support QUIC"+        exitFailure+#endif #else     checkTLS opt = when (opt_service opt > 1) $ do         hPutStrLn stderr "This mighty does not support TLS"

@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  module Server (server, defaultDomain, defaultPort) where @@ -6,13 +8,9 @@ import Control.Exception (try) import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as BS-#ifdef HTTP_OVER_TLS-import Data.Char (isSpace)-import Data.List (dropWhile, dropWhileEnd, break)-#endif import Data.Streaming.Network (bindPortTCP)-import Network.Socket (Socket, close) import qualified Network.HTTP.Client as H+import Network.Socket (Socket, close) import Network.Wai.Application.Classic hiding ((</>)) import Network.Wai.Handler.Warp import Network.Wai.Logger@@ -21,6 +19,7 @@ import System.IO.Error (ioeGetErrorString) import System.Posix (exitImmediately, Handler(..), getProcessID, setFileMode) import System.Posix.Signals (sigCHLD)+import qualified System.TimeManager as T  import Program.Mighty import WaiApp@@ -28,12 +27,32 @@ import qualified Network.Wai.Middleware.Push.Referer as P  #ifdef HTTP_OVER_TLS-import Control.Concurrent.Async (concurrently)-import Control.Monad (void)-import Network.Wai.Handler.WarpTLS+import Control.Concurrent.Async (concurrently_)+import Data.Char (isSpace)+import Data.List (dropWhileEnd)+import Network.TLS (Credentials(..),SessionManager)+import qualified Network.TLS as TLS import Network.TLS.SessionManager+import qualified Network.TLS.SessionManager as SM+import Network.Wai.Handler.WarpTLS+#ifdef HTTP_OVER_QUIC+import Control.Concurrent.Async (mapConcurrently_)+import Data.Bits+import Data.ByteString (ByteString)+import Data.List (find)+import Data.Maybe (fromJust)+import qualified Network.QUIC.Internal as Q+import Network.Wai.Handler.WarpQUIC+#ifdef DROP_EXCEPT_BIND+import Control.Monad (forM_)+import Foreign.C.Types (CInt(..))+import System.Directory (listDirectory)+import System.Posix.Signals (sigUSR1)+#endif+#endif #else-data TLSSettings = TLSSettings+data Credentials+data SessionManager #endif  ----------------------------------------------------------------@@ -41,13 +60,13 @@ defaultDomain :: Domain defaultDomain = "localhost" -defaultPort :: Int+defaultPort :: Natural defaultPort = 80  openFileNumber :: Integer openFileNumber = 10000 -logBufferSize :: Int+logBufferSize :: Natural logBufferSize = 4 * 1024 * 10  managerNumber :: Int@@ -65,8 +84,18 @@     svc <- openService opt     unless debug writePidFile     rdr <- newRouteDBRef route-    tlsSetting <- getTlsSetting opt-    setGroupUser (opt_user opt) (opt_group opt)+    tmgr <- T.initialize (naturalToInt (opt_connection_timeout opt) * 1000000)+#ifdef HTTP_OVER_TLS+    mcred <- Just <$> loadCredentials opt+    smgr <- Just <$> SM.newSessionManager SM.defaultConfig { dbMaxSize = 1000 }+#else+    let mcred = Nothing+        smgr = Nothing+#endif+    _changed <- setGroupUser (opt_user opt) (opt_group opt)+#ifdef DROP_EXCEPT_BIND+    when _changed dropExceptBind+#endif     logCheck logtype     (zdater,_) <- clockDateCacher     ap <- initLogger FromSocket logtype zdater@@ -77,9 +106,8 @@     setHandlers opt rpt svc remover rdr      report rpt "Mighty started"-    runInUnboundThread $ mighty opt rpt svc lgr pushlgr mgr rdr tlsSetting+    runInUnboundThread $ mighty opt rpt svc lgr pushlgr mgr rdr mcred smgr tmgr     report rpt "Mighty retired"-    finReporter rpt     remover     exitSuccess   where@@ -95,12 +123,12 @@     logspec = FileLogSpec {         log_file          = opt_log_file opt       , log_file_size     = fromIntegral $ opt_log_file_size opt-      , log_backup_number = opt_log_backup_number opt+      , log_backup_number = naturalToInt $ opt_log_backup_number opt       }     logtype       | not (opt_logging opt) = LogNone-      | debug                 = LogStdout logBufferSize-      | otherwise             = LogFile logspec logBufferSize+      | debug                 = LogStdout $ naturalToInt logBufferSize+      | otherwise             = LogFile logspec $ naturalToInt logBufferSize  setHandlers :: Option -> Reporter -> Service -> LogRemover -> RouteDBRef -> IO () setHandlers opt rpt svc remover rdr = do@@ -112,41 +140,34 @@   where     stopHandler = Catch $ do         report rpt "Mighty finished"-        finReporter rpt         closeService svc         remover         exitImmediately ExitSuccess     retireHandler = Catch $ do         report rpt "Mighty retiring"         closeService svc -- this lets warp break-    infoHandler = Catch $ report rpt "obsolted"+    infoHandler = Catch $ report rpt "obsoleted"     reloadHandler = Catch $ do         ifRouteFileIsValid rpt opt $ \newroute -> do             writeRouteDBRef rdr newroute             report rpt "Mighty reloaded" -getTlsSetting :: Option -> IO TLSSettings-getTlsSetting _opt = #ifdef HTTP_OVER_TLS-    case opt_service _opt of-        0 -> return defaultTlsSettings -- this is dummy-        _ -> do cert <- BS.readFile $ opt_tls_cert_file _opt-                let strip = dropWhileEnd isSpace . dropWhile isSpace-                    split "" = []-                    split s = case break (',' ==) s of-                      ("",r)  -> split (tail r)-                      (s',"") -> [s']-                      (s',r)  -> s' : split (tail r)-                    chain_files = map strip $ split $ opt_tls_chain_files _opt-                chains <- mapM BS.readFile chain_files-                key  <- BS.readFile $ opt_tls_key_file _opt-                let settings0 = tlsSettingsChainMemory cert chains key-                    settings = settings0 {-                        tlsSessionManagerConfig = Just defaultConfig { dbMaxSize = 1000 }-                      }-                return settings-#else-    return TLSSettings+loadCredentials :: Option -> IO Credentials+loadCredentials opt = do+    cert   <- BS.readFile $ opt_tls_cert_file opt+    chains <- mapM BS.readFile chain_files+    key    <- BS.readFile $ opt_tls_key_file opt+    let Right cred = TLS.credentialLoadX509ChainFromMemory cert chains key+    return $ Credentials [cred]+  where+    strip = dropWhileEnd isSpace . dropWhile isSpace+    split "" = []+    split s = case break (',' ==) s of+      ("",r)  -> split (tail r)+      (s',"") -> [s']+      (s',r)  -> s' : split (tail r)+    chain_files = map strip $ split $ opt_tls_chain_files opt #endif  ----------------------------------------------------------------@@ -163,35 +184,56 @@ mighty :: Option -> Reporter -> Service        -> ApacheLogger -> ServerPushLogger        -> ConnPool -> RouteDBRef-       -> TLSSettings+       -> Maybe Credentials -> Maybe SessionManager -> T.Manager        -> IO ()-mighty opt rpt svc lgr pushlgr mgr rdr _tlsSetting+mighty opt rpt svc lgr pushlgr mgr rdr _mcreds _msmgr tmgr   = reportDo rpt $ case svc of     HttpOnly s  -> runSettingsSocket setting s app #ifdef HTTP_OVER_TLS-    HttpsOnly s -> runTLSSocket _tlsSetting setting s app-    HttpAndHttps s1 s2 -> void $ concurrently+    HttpsOnly s -> runTLSSocket tlsSetting setting s app+    HttpAndHttps s1 s2 -> concurrently_         (runSettingsSocket setting s1 app)-        (runTLSSocket _tlsSetting setting s2 app)+        (runTLSSocket tlsSetting setting s2 app)+#ifdef HTTP_OVER_QUIC+    QUIC s1 s2 -> do+        let quicPort' = BS.pack $ show quicPort+            strver Q.Version1 = ""+            strver v = BS.append "-" $ BS.pack $ show $ fromVersion v+            quicDrafts = map strver quicVersions+            value v = BS.concat ["h3",v,"=\":",quicPort',"\""]+            altsvc = BS.intercalate "," $ map value quicDrafts+            settingT = setAltSvc altsvc setting+        mapConcurrently_ id [runSettingsSocket        setting  s1 app+                            ,runTLSSocket  tlsSetting settingT s2 app+                            ,runQUIC       qconf      setting     app+                            ] #else     _ -> error "never reach" #endif+#else+    _ -> error "never reach"+#endif   where-    app = P.pushOnReferer P.defaultSettings-                          (fileCgiApp cspec filespec cgispec revproxyspec rdr)+    app = P.pushOnReferer P.defaultSettings $ fileCgiApp cspec filespec cgispec revproxyspec rdr     debug = opt_debug_mode opt     -- We don't use setInstallShutdownHandler because we may use     -- two sockets for HTTP and HTTPS.-    setting = setPort            (opt_port opt) -- just in case+    setting = setPort            (naturalToInt $ opt_port opt) -- just in case             $ setHost            (fromString (opt_host opt))  -- just in case             $ setOnException     (if debug then printStdout else warpHandler rpt)-            $ setTimeout         (opt_connection_timeout opt) -- seconds-            $ setFdCacheDuration (opt_fd_cache_duration opt)+            $ setManager         tmgr+            $ setFdCacheDuration (naturalToInt $ opt_fd_cache_duration opt)             $ setFileInfoCacheDuration 10             $ setServerName      serverName             $ setLogger          lgr             $ setServerPushLogger pushlgr             defaultSettings+#ifdef HTTP_OVER_TLS+    tlsSetting = defaultTlsSettings {+        tlsCredentials    = _mcreds+      , tlsSessionManager = _msmgr+      }+#endif     serverName = BS.pack $ opt_server_name opt     cspec = ClassicAppSpec {         softwareName = serverName@@ -207,10 +249,41 @@     revproxyspec = RevProxyAppSpec {         revProxyManager = mgr       }+#ifdef HTTP_OVER_QUIC+    quicAddr = read <$> opt_quic_addr opt+    quicPort = fromIntegral $ opt_quic_port opt+    quicVersions = Q.scVersions Q.defaultServerConfig+    qconf = Q.defaultServerConfig {+            Q.scAddresses      = (,quicPort) <$> quicAddr+          , Q.scALPN           = Just chooseALPN+          , Q.scRequireRetry   = False+          , Q.scSessionManager = fromJust _msmgr+          , Q.scUse0RTT        = True+          , Q.scDebugLog       = opt_quic_debug_dir opt+          , Q.scQLog           = opt_quic_qlog_dir opt+          , Q.scCredentials    = fromJust _mcreds+          } +chooseALPN :: Q.Version -> [ByteString] -> IO ByteString+chooseALPN ver protos = case find (\x -> x == h3 || x == hq) protos of+  Nothing    -> return ""+  Just proto -> return proto+  where+    h3 | ver == Q.Version1 = "h3"+       | otherwise = "h3-" `BS.append` BS.pack (show (fromVersion ver))+    hq | ver == Q.Version1 = "hq-interop"+       | otherwise = "hq-" `BS.append` BS.pack (show (fromVersion ver))++fromVersion :: Q.Version -> Int+fromVersion (Q.Version ver) = fromIntegral (0x000000ff .&. ver)+#endif+ ---------------------------------------------------------------- -data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket+data Service = HttpOnly Socket+             | HttpsOnly Socket+             | HttpAndHttps Socket Socket+             | QUIC Socket Socket  ---------------------------------------------------------------- @@ -226,13 +299,20 @@       debugMessage $ urlForHTTP httpPort       debugMessage $ urlForHTTPS httpsPort       return $ HttpAndHttps s1 s2+  | service == 3 = do+      s1 <- bindPortTCP httpPort hostpref+      s2 <- bindPortTCP httpsPort hostpref+      debugMessage $ urlForHTTP httpPort+      debugMessage $ urlForHTTPS httpsPort+      debugMessage "QUIC is also available via Alt-Svc"+      return $ QUIC s1 s2   | otherwise = do       s <- bindPortTCP httpPort hostpref       debugMessage $ urlForHTTP httpPort       return $ HttpOnly s   where-    httpPort  = opt_port opt-    httpsPort = opt_tls_port opt+    httpPort  = naturalToInt $ opt_port opt+    httpsPort = naturalToInt $ opt_tls_port opt     hostpref  = fromString $ opt_host opt     service = opt_service opt     debug = opt_debug_mode opt@@ -251,6 +331,7 @@ closeService (HttpOnly s)         = close s closeService (HttpsOnly s)        = close s closeService (HttpAndHttps s1 s2) = close s1 >> close s2+closeService (QUIC s1 s2)         = close s1 >> close s2  ---------------------------------------------------------------- @@ -264,4 +345,16 @@   where     responseTimeout       | opt_proxy_timeout opt == 0 = H.managerResponseTimeout H.defaultManagerSettings-      | otherwise                  = H.responseTimeoutMicro (opt_proxy_timeout opt * 1000000) -- micro seconds+      | otherwise                  = H.responseTimeoutMicro (naturalToInt $ opt_proxy_timeout opt * 1000000) -- micro seconds++#ifdef DROP_EXCEPT_BIND+foreign import ccall unsafe "send_signal"+  c_send_signal :: CInt -> CInt -> IO ()++dropExceptBind :: IO ()+dropExceptBind = do+    pid <- getProcessID+    strtids <- listDirectory ("/proc/" ++ show pid ++ "/task")+    let tids = map read strtids :: [Int]+    forM_ tids $ \tid -> c_send_signal (fromIntegral tid) sigUSR1+#endif

@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module WaiApp (fileCgiApp) where @@ -36,7 +37,7 @@         Found (RouteCGI   src dst) ->             cgiApp cspec cgispec (CgiRoute src dst) req' respond         Found (RouteRevProxy src dst dom prt) ->-            revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req respond+            revProxyApp cspec revproxyspec (RevProxyRoute src dst dom (naturalToInt prt)) req respond   where     (host, _) = hostPort req     rawpath = rawPathInfo req

@@ -1,3 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+ module ConfigSpec where  import Program.Mighty@@ -7,8 +10,44 @@ spec = do     describe "parseConfig" $ do         it "parses example.conf correctly" $ do-            res <- parseOption "conf/example.conf" "foo"-            res `shouldBe` ans+            res <- parseOption "conf/example.conf"+            res { opt_server_name = "foo" } `shouldBe` ans +#ifdef DHALL+    describe "parseDhall" $ do+        it "parses example.dhall correctly" $ do+            res <- parseOptionDhall "./conf/example.dhall"+            res { opt_server_name = "foo" } `shouldBe` ans+#endif+ ans :: Option-ans = Option {opt_port = 80, opt_host = "*", opt_debug_mode = True, opt_user = "root", opt_group = "root", opt_pid_file = "/var/run/mighty.pid", opt_logging = True, opt_log_file = "/var/log/mighty", opt_log_file_size = 16777216, opt_log_backup_number = 10, opt_index_file = "index.html", opt_index_cgi = "index.cgi", opt_status_file_dir = "/usr/local/share/mighty/status", opt_connection_timeout = 30, opt_fd_cache_duration = 10, opt_server_name = "foo", opt_routing_file = Nothing, opt_tls_port = 443, opt_tls_cert_file = "cert.pem", opt_tls_chain_files = "chain.pem", opt_tls_key_file = "privkey.pem", opt_service = 0, opt_report_file = "/tmp/mighty_report", opt_proxy_timeout = 0}+ans = Option+    { opt_port = 80+    , opt_host = "*"+    , opt_debug_mode = True+    , opt_user  = "root"+    , opt_group = "root"+    , opt_pid_file    = "/var/run/mighty.pid"+    , opt_report_file = "/tmp/mighty_report"+    , opt_logging = True+    , opt_log_file = "/var/log/mighty"+    , opt_log_file_size = 16777216+    , opt_log_backup_number = 10+    , opt_index_file = "index.html"+    , opt_index_cgi  = "index.cgi"+    , opt_status_file_dir = "/usr/local/share/mighty/status"+    , opt_connection_timeout = 30+    , opt_proxy_timeout      = 0+    , opt_fd_cache_duration  = 10+    , opt_service = 0+    , opt_tls_port = 443+    , opt_tls_cert_file   = "cert.pem"+    , opt_tls_chain_files = "chain.pem"+    , opt_tls_key_file    = "privkey.pem"+    , opt_quic_addr = ["127.0.0.1","::1"]+    , opt_quic_port = 443+    , opt_quic_debug_dir = Nothing+    , opt_quic_qlog_dir  = Nothing+    , opt_server_name = "foo"+    , opt_routing_file = Nothing+    }