diff --git a/Program/Mighty/Config.hs b/Program/Mighty/Config.hs --- a/Program/Mighty/Config.hs +++ b/Program/Mighty/Config.hs @@ -17,7 +17,9 @@ , Option(..) ) where +import Control.Monad (forM_, unless) import Data.List.Split (splitOn) +import System.IO (hPutStrLn, stderr) import Text.Parsec import Text.Parsec.ByteString.Lazy #ifdef DHALL @@ -108,9 +110,44 @@ ---------------------------------------------------------------- -- | Parsing a configuration file to get an 'Option'. +-- An 'IOException' is thrown if a value has a wrong type. +-- Unknown keys are reported to stderr. parseOption :: FilePath -> IO Option -parseOption file = makeOpt defaultOption <$> parseConfig file +parseOption file = do + conf <- parseConfig file + forM_ conf $ \(k, v) -> case lookup k keyTypes of + Nothing -> hPutStrLn stderr $ file ++ ": unknown key: " ++ k + Just ty -> unless (ty v) $ + ioError $ userError $ file ++ ": wrong value for " ++ k ++ ": " ++ showCV v + return $ makeOpt defaultOption conf + where + showCV (CV_Natural n) = show n + showCV (CV_Bool b) = if b then "Yes" else "No" + showCV (CV_String s) = s +-- | Keys and their types. Strings accept any values. +keyTypes :: [(String, ConfValue -> Bool)] +keyTypes = + [ ("Port", natural), ("Host", anyValue), ("Debug_Mode", bool) + , ("User", anyValue), ("Group", anyValue) + , ("Pid_File", anyValue), ("Report_File", anyValue), ("Logging", bool) + , ("Log_File", anyValue), ("Log_File_Size", natural) + , ("Log_Backup_Number", natural) + , ("Index_File", anyValue), ("Index_Cgi", anyValue) + , ("Status_File_Dir", anyValue), ("Connection_Timeout", natural) + , ("Proxy_Timeout", natural), ("Fd_Cache_Duration", natural) + , ("Service", natural), ("Tls_Port", natural) + , ("Tls_Cert_File", anyValue), ("Tls_Chain_Files", anyValue) + , ("Tls_Key_File", anyValue), ("Quic_Addr", anyValue), ("Quic_Port", natural) + , ("Quic_Debug_Dir", anyValue), ("Quic_Qlog_Dir", anyValue) + ] + where + natural CV_Natural{} = True + natural _ = False + bool CV_Bool{} = True + bool _ = False + anyValue _ = True + #ifdef DHALL parseOptionDhall :: FilePath -> IO Option parseOptionDhall = fmap optionFromDhall . input auto . fromString @@ -201,18 +238,19 @@ fromConf (CV_Bool b) = b fromConf _ = error "fromConf bool" +-- Numbers and booleans are also accepted as strings, e.g. "User: 1000". instance FromConf String where fromConf (CV_String s) = s - fromConf _ = error "fromConf string" + fromConf (CV_Natural n) = show n + fromConf (CV_Bool b) = if b then "Yes" else "No" instance FromConf (Maybe String) where - fromConf (CV_String "") = Nothing - fromConf (CV_String s) = Just s - fromConf _ = error "fromConf string" + fromConf v = case fromConf v of + "" -> Nothing + s -> Just s instance FromConf [String] where - fromConf (CV_String s) = splitOn "," s - fromConf _ = error "fromConf string" + fromConf v = filter (not . null) $ splitOn "," $ fromConf v ---------------------------------------------------------------- diff --git a/Program/Mighty/Parser.hs b/Program/Mighty/Parser.hs --- a/Program/Mighty/Parser.hs +++ b/Program/Mighty/Parser.hs @@ -12,7 +12,7 @@ comment, ) where -import Control.Exception +import qualified Control.Exception as E import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec @@ -31,7 +31,7 @@ bs <- BL.hGetContents hdl case parse p "parseFile" bs of Right x -> return x - Left e -> throwIO . userError . show $ e + Left e -> E.throwIO . userError . show $ e -- | 'Parser' to consume zero or more white spaces -- diff --git a/Program/Mighty/Process.hs b/Program/Mighty/Process.hs --- a/Program/Mighty/Process.hs +++ b/Program/Mighty/Process.hs @@ -48,11 +48,8 @@ .| CL.filter mighty .| CL.consume commandName = last . split '/' . command - mighty ps = - "mighty" `BS.isInfixOf` name - && not ("mightyctl" `BS.isInfixOf` name) - where - name = commandName ps + -- Not "mightyctl", "mighty-mkindex", etc. + mighty ps = commandName ps == "mighty" ---------------------------------------------------------------- @@ -63,7 +60,7 @@ masters = filter iAmMaster ps rest = filter (not . iAmMaster) ps candidates = - map head $ + concat $ filter (\xs -> length xs == 1) $ -- master is alone groupBy ((==) `on` ppid) $ sortOn ppid rest diff --git a/Program/Mighty/Report.hs b/Program/Mighty/Report.hs --- a/Program/Mighty/Report.hs +++ b/Program/Mighty/Report.hs @@ -14,8 +14,7 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import Control.Exception -import qualified Control.Exception as E (catch) +import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -27,6 +26,16 @@ import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID) +import System.Posix.IO ( + OpenFileFlags (..), + OpenMode (WriteOnly), + defaultFileFlags, + fdToHandle, + openFd, + ) +#if !MIN_VERSION_unix(2,8,0) +import System.Posix.Files (getSymbolicLinkStatus, isSymbolicLink) +#endif import Network.HTTP2.Client (HTTP2Error) #ifdef HTTP_OVER_TLS @@ -50,13 +59,31 @@ | otherwise = FileOnly report :: Reporter -> ByteString -> IO () -report (Reporter method reportFile) msg = handle (\(SomeException _) -> return ()) $ do +report (Reporter method reportFile) msg = E.handle (\(E.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.appendFile reportFile logmsg - when (method == FileAndStdout) $ BS.putStr logmsg + -- Flushing since stdout may be a file and Mighty may exit immediately. + when (method == FileAndStdout) $ BS.putStr logmsg >> hFlush stdout + appendNoFollow reportFile logmsg +-- | Appending without following a symbolic link since the report +-- file may be in a world-writable directory such as /tmp. +appendNoFollow :: FilePath -> ByteString -> IO () +appendNoFollow file msg = E.bracket open hClose (`BS.hPut` msg) + where +#if MIN_VERSION_unix(2,8,0) + open = openFd file WriteOnly flags >>= fdToHandle + flags = defaultFileFlags{append = True, nofollow = True, creat = Just 0o644} +#else + open = do + isLink <- (isSymbolicLink <$> getSymbolicLinkStatus file) + `E.catch` \(_ :: E.IOException) -> return False + when isLink $ E.throwIO $ userError "symbolic link" + openFd file WriteOnly (Just 0o644) flags >>= fdToHandle + flags = defaultFileFlags{append = True} +#endif + ---------------------------------------------------------------- reportDo :: Reporter -> IO () -> IO () @@ -65,20 +92,20 @@ ---------------------------------------------------------------- {- FOURMOLU_DISABLE -} -warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () +warpHandler :: Reporter -> Maybe Request -> E.SomeException -> IO () warpHandler rpt _ se - | Just (_ :: ExitCode) <- fromException se = return () - | Just (e :: IOException) <- fromException se = + | Just (_ :: ExitCode) <- E.fromException se = return () + | Just (e :: E.IOException) <- E.fromException se = if ioeGetErrorType e `elem` [ResourceVanished, InvalidArgument] then return () else report rpt $ bshow se - | Just (_ :: InvalidRequest) <- fromException se = return () -- Warp - | Just (_ :: HTTP2Error) <- fromException se = return () + | Just (_ :: InvalidRequest) <- E.fromException se = return () -- Warp + | Just (_ :: HTTP2Error) <- E.fromException se = return () #ifdef HTTP_OVER_TLS - | Just (_ :: TLSException) <- fromException se = return () - | Just (_ :: WarpTLSException) <- fromException se = return () + | Just (_ :: TLSException) <- E.fromException se = return () + | Just (_ :: WarpTLSException) <- E.fromException se = return () #ifdef HTTP_OVER_QUIC - | Just (_ :: QUICException) <- fromException se = return () + | Just (_ :: QUICException) <- E.fromException se = return () #endif #endif | otherwise = report rpt $ bshow se @@ -86,5 +113,5 @@ ---------------------------------------------------------------- -printStdout :: Maybe Request -> SomeException -> IO () +printStdout :: Maybe Request -> E.SomeException -> IO () printStdout _ x = print x >> hFlush stdout diff --git a/Program/Mighty/Resource.hs b/Program/Mighty/Resource.hs --- a/Program/Mighty/Resource.hs +++ b/Program/Mighty/Resource.hs @@ -6,7 +6,7 @@ unlimit, ) where -import Control.Exception +import qualified System.IO.Error as E import System.Posix ---------------------------------------------------------------- @@ -28,8 +28,12 @@ root <- amIrootUser if root then do - getGroupEntryForName group >>= setGroupID . groupID - getUserEntryForName user >>= setUserID . userID + gid <- groupID <$> getGroupEntryForName group + uid <- userID <$> getUserEntryForName user + -- Otherwise, the supplementary groups of root are kept. + setGroups [gid] + setGroupID gid + setUserID uid return True else return False @@ -38,7 +42,7 @@ -- | Set the limit of open files. unlimit :: Integer -> IO () -unlimit limit = handle (\(SomeException _) -> return ()) $ do +unlimit limit = handleIOError (\_ -> return ()) $ do hard <- hardLimit <$> getResourceLimit ResourceOpenFiles let lim = if hard == ResourceLimitInfinity @@ -47,3 +51,5 @@ else ResourceLimits hard hard setResourceLimit ResourceOpenFiles lim + where + handleIOError = flip E.catchIOError diff --git a/Program/Mighty/Route.hs b/Program/Mighty/Route.hs --- a/Program/Mighty/Route.hs +++ b/Program/Mighty/Route.hs @@ -5,6 +5,7 @@ module Program.Mighty.Route ( -- * Paring a routing file parseRoute, + normalizeDomain, -- * Types RouteDB, @@ -25,6 +26,7 @@ import Control.Monad import Data.ByteString import qualified Data.ByteString.Char8 as BS +import Data.Char (toLower) import Data.IORef #ifdef DHALL import GHC.Natural (Natural) @@ -35,6 +37,9 @@ import Program.Mighty.Parser +-- $setup +-- >>> :seti -XOverloadedStrings + ---------------------------------------------------------------- -- | A logical path specified in URL. @@ -86,8 +91,21 @@ open = () <$ char '[' *> spcs close = () <$ char ']' *> spcs doms = (domain `sepBy1` sep) <* spcs - domain = BS.pack <$> many1 (noneOf "[], \t\n") + domain = normalizeDomain . BS.pack <$> many1 (noneOf "[], \t\n") sep = () <$ spcs1 + +-- | Domain names are case-insensitive and may end with a dot. +-- +-- >>> normalizeDomain "WWW.Example.COM." +-- "www.example.com" +-- >>> normalizeDomain "*" +-- "*" +normalizeDomain :: Domain -> Domain +normalizeDomain dom = BS.map toLower dom' + where + dom' = case BS.unsnoc dom of + Just (d, '.') -> d + _ -> dom data Op = OpFile | OpCGI | OpRevProxy | OpRedirect diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: mighttpd2 -version: 4.0.10 +version: 4.0.11 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -83,7 +83,7 @@ unix-time, unordered-containers, wai >=3.2 && <3.3, - wai-app-file-cgi >=3.1.9 && <3.2, + wai-app-file-cgi >=3.3 && <3.4, warp >=3.4 && <3.5 if impl(ghc >=8) @@ -129,7 +129,7 @@ streaming-commons, time-manager, wai >=3.2 && <3.3, - wai-app-file-cgi >=3.1.9 && <3.2, + wai-app-file-cgi >=3.3 && <3.4, wai-logger >=2.3.0, warp >=3.4 && <3.5 @@ -192,16 +192,28 @@ main-is: Spec.hs build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test src + ghc-options: -threaded other-modules: ConfigSpec + ReportSpec RouteSpec + WaiApp + WaiAppSpec default-language: Haskell2010 build-depends: base >=4.9 && <5, + bytestring, + directory, + filepath, hspec >=1.3, mighttpd2, - http-client >=0.5 + http-client >=0.5, + http-types, + unix, + wai, + wai-app-file-cgi >=3.3 && <3.4, + warp >=3.4 && <3.5 if flag(tls) build-depends: diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -5,10 +5,8 @@ module Server (server, defaultDomain, defaultPort) where import Control.Concurrent (runInUnboundThread) -import Control.Exception (try) import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as BS -import Data.Either (fromRight) import Data.Streaming.Network (bindPortTCP, bindPortUDP) #if __GLASGOW_HASKELL__ >= 906 import GHC.Conc.Sync @@ -22,9 +20,10 @@ import Network.Wai.Handler.Warp import Network.Wai.Logger import System.Exit (ExitCode(..), exitSuccess) +import System.IO (hFlush, stdout) import System.IO.Error (ioeGetErrorString) +import qualified System.IO.Error as E import System.Posix (exitImmediately, Handler(..), getProcessID, setFileMode) -import System.Posix.Signals (sigCHLD) import qualified System.TimeManager as T import Program.Mighty @@ -78,7 +77,14 @@ server opt rpt route runMighty = reportDo rpt $ do labelMe "Mighty main" unlimit openFileNumber - svc <- openService opt + -- Exiting immediately since reportDo swallows ExitCode. + -- A script can retry while a retiring Mighty holds the port. + svc <- openService opt `E.catchIOError` \e -> do + report rpt $ bshow e + hFlush stdout + -- exitImmediately returns () if unix < 2.8. + _ <- exitImmediately $ ExitFailure 1 + E.ioError e runMighty $ do unless debug writePidFile rdr <- newRouteDBRef route @@ -131,7 +137,6 @@ setHandler sigRetire retireHandler setHandler sigInfo infoHandler setHandler sigReload reloadHandler - setHandler sigCHLD Ignore -- for CGI where stopHandler = Catch $ do report rpt "Mighty finished" @@ -170,8 +175,9 @@ cert <- BS.readFile $ opt_tls_cert_file opt chains <- mapM BS.readFile chain_files key <- BS.readFile $ opt_tls_key_file opt - let cred = fromRight (error "loadCredentials") $ TLS.credentialLoadX509ChainFromMemory cert chains key - return $ Credentials [cred] + case TLS.credentialLoadX509ChainFromMemory cert chains key of + Left err -> ioError $ userError $ "loadCredentials: " ++ err + Right cred -> return $ Credentials [cred] where strip = dropWhileEnd isSpace . dropWhile isSpace split "" = [] @@ -187,8 +193,9 @@ ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO () ifRouteFileIsValid rpt opt act = case opt_routing_file opt of Nothing -> return () - Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError_ act + Just rfile -> E.tryIOError (parseRoute rfile defaultDomain defaultPort) >>= either reportError_ act where + reportError_ :: IOError -> IO () reportError_ = report rpt . BS.pack . ioeGetErrorString ---------------------------------------------------------------- @@ -257,7 +264,7 @@ , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x } cgispec = CgiAppSpec { - indexCgi = "index.cgi" + indexCgi = fromString $ opt_index_cgi opt } revproxyspec = RevProxyAppSpec { revProxyManager = mgr diff --git a/src/WaiApp.hs b/src/WaiApp.hs --- a/src/WaiApp.hs +++ b/src/WaiApp.hs @@ -1,8 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module WaiApp (fileCgiApp) where +module WaiApp ( + fileCgiApp, + -- * For testing + Perhaps (..), + isHiddenPath, + getBlock, + getRoute, +) where + import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types ( @@ -17,7 +25,7 @@ import Program.Mighty -data Perhaps a = Found a | Redirect | Fail +data Perhaps a = Found a | Redirect | Fail deriving (Eq, Show) fileCgiApp :: ClassicAppSpec @@ -38,14 +46,14 @@ fastResponse respond st defaultHeader "Precondition Failed\r\n" Redirect -> do let st = movedPermanently301 - hdr = defaultHeader ++ redirectHeader req' + hdr = defaultHeader ++ redirectHeader req fastResponse respond st hdr "Moved Permanently\r\n" Found (RouteFile src dst) -> - fileApp cspec filespec (FileRoute src dst) req' respond + fileApp cspec filespec (FileRoute src dst) req respond Found (RouteRedirect src dst) -> - redirectApp cspec (RedirectRoute src dst) req' respond + redirectApp cspec (RedirectRoute src dst) req respond Found (RouteCGI src dst) -> - cgiApp cspec cgispec (CgiRoute src dst) req' respond + cgiApp cspec cgispec (CgiRoute src dst) req respond Found (RouteRevProxy src dst dom prt) -> revProxyApp cspec @@ -54,16 +62,26 @@ req respond where - (host, _) = hostPort req + host = normalizeDomain $ fst $ hostPort req rawpath = rawPathInfo req path = urlDecode False rawpath - dotFile = not (BS.isPrefixOf "/.well-known/" rawpath) && (BS.isPrefixOf "." rawpath || BS.isInfixOf "/." rawpath) + dotFile = isHiddenPath path mmp um = case getBlock host um of Nothing -> Fail Just blk -> getRoute path blk fastResponse resp st hdr body = resp $ responseLBS st hdr body defaultHeader = [("Content-Type", "text/plain")] - req' = req{rawPathInfo = path} -- FIXME + +-- | Whether the decoded path contains a segment starting with a dot. +-- Segments are split by both slash and backslash so that a backslash +-- cannot bypass this. "/.well-known/" is allowed for ACME. +isHiddenPath :: ByteString -> Bool +isHiddenPath path = any ("." `BS.isPrefixOf`) segs' + where + segs = BS.splitWith (\c -> c == '/' || c == '\\') path + segs' = case segs of + "" : ".well-known" : rest -> rest + _ -> segs getBlock :: ByteString -> RouteDB -> Maybe [Route] getBlock _ [] = Nothing diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -3,6 +3,10 @@ module ConfigSpec where +import Control.Exception (bracket_) +import System.Directory (getTemporaryDirectory, removeFile) +import System.FilePath (()) + import Program.Mighty import Test.Hspec @@ -13,12 +17,28 @@ res <- parseOption "conf/example.conf" res{opt_server_name = "foo"} `shouldBe` ans + it "accepts numbers as strings and ignores empty addresses" $ do + res <- withConfig "User: 1000\nQuic_Addr: 0.0.0.0,\n" parseOption + opt_user res `shouldBe` "1000" + opt_quic_addr res `shouldBe` ["0.0.0.0"] + it "rejects a value with a wrong type" $ do + withConfig "Port: http\n" parseOption `shouldThrow` anyIOException + it "ignores unknown keys" $ do + res <- withConfig "Prot: 8080\n" parseOption + opt_port res `shouldBe` opt_port defaultOption + #ifdef DHALL describe "parseDhall" $ do it "parses example.dhall correctly" $ do res <- parseOptionDhall "./conf/example.dhall" res { opt_server_name = "foo" } `shouldBe` ans #endif + +withConfig :: String -> (FilePath -> IO a) -> IO a +withConfig conf act = do + dir <- getTemporaryDirectory + let file = dir "mighty-config-spec.conf" + bracket_ (writeFile file conf) (removeFile file) (act file) ans :: Option ans = diff --git a/test/ReportSpec.hs b/test/ReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReportSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ReportSpec where + +import Control.Exception (bracket) +import System.Directory +import System.FilePath (()) +import System.Posix.Files (createSymbolicLink) +import Test.Hspec + +import Program.Mighty + +spec :: Spec +spec = describe "report" $ around withDir $ do + it "appends to the report file" $ \dir -> do + let file = dir "report" + rpt = initReporter False file + report rpt "foo" + report rpt "bar" + ls <- lines <$> readFile file + length ls `shouldBe` 2 + it "does not follow a symbolic link" $ \dir -> do + let victim = dir "victim" + link = dir "link" + writeFile victim "original\n" + createSymbolicLink victim link + report (initReporter False link) "foo" + readFile victim `shouldReturn` "original\n" + +withDir :: (FilePath -> IO ()) -> IO () +withDir body = do + tmp <- getTemporaryDirectory + let dir = tmp "mighty-report-spec" + bracket (mk dir) removeDirectoryRecursive body + where + mk dir = do + removePathForcibly dir + createDirectory dir + return dir diff --git a/test/WaiAppSpec.hs b/test/WaiAppSpec.hs new file mode 100644 --- /dev/null +++ b/test/WaiAppSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WaiAppSpec where + +import Control.Exception (bracket) +import Data.ByteString (ByteString) +import qualified Network.HTTP.Client as H +import Network.HTTP.Types (Status, statusCode) +import Network.Wai.Application.Classic hiding (()) +import Network.Wai.Handler.Warp (testWithApplication) +import System.Directory +import System.FilePath (()) +import Test.Hspec + +import Program.Mighty +import WaiApp + +spec :: Spec +spec = do + describe "isHiddenPath" $ do + it "detects segments starting with a dot" $ do + isHiddenPath "/foo/bar.html" `shouldBe` False + isHiddenPath "/a.d/b" `shouldBe` False + isHiddenPath "/.git/config" `shouldBe` True + isHiddenPath "/foo/.htaccess" `shouldBe` True + isHiddenPath "/foo/../bar" `shouldBe` True + it "splits segments by backslash too" $ + isHiddenPath "/foo\\.git\\config" `shouldBe` True + it "allows /.well-known/ but not hidden segments under it" $ do + isHiddenPath "/.well-known/acme-challenge/x" `shouldBe` False + isHiddenPath "/.well-known/.git/x" `shouldBe` True + isHiddenPath "/foo/.well-known/x" `shouldBe` True + + describe "getBlock" $ do + it "finds the block of the domain or the wildcard" $ do + getBlock "localhost" db `shouldBe` Just [fileRoute] + getBlock "example.org" db `shouldBe` Just [cgiRoute] + getBlock "example.org" (take 1 db) `shouldBe` Nothing + + describe "getRoute" $ do + let routes = [cgiRoute, fileRoute] + it "finds the route whose source is a prefix" $ do + getRoute "/cgi-bin/foo" routes `shouldBe` Found cgiRoute + getRoute "/index.html" routes `shouldBe` Found fileRoute + it "redirects to the mount point" $ + getRoute "/cgi-bin" routes `shouldBe` Redirect + it "fails if no route matches" $ + getRoute "/foo" [cgiRoute] `shouldBe` Fail + + describe "fileCgiApp" $ around withSite $ do + it "matches the domain case-insensitively" $ \site -> do + get site "localhost" "/" `shouldReturn` 200 + get site "LOCALHOST" "/" `shouldReturn` 200 + get site "localhost." "/" `shouldReturn` 200 + get site "LocalHost:8080" "/" `shouldReturn` 200 + it "returns 412 for an unknown domain" $ \site -> + get site "example.org" "/" `shouldReturn` 412 + it "rejects hidden files even if encoded" $ \site -> do + get site "localhost" "/.git/config" `shouldReturn` 400 + get site "localhost" "/%2egit/config" `shouldReturn` 400 + get site "localhost" "/%5c.git/config" `shouldReturn` 400 + it "allows /.well-known/" $ \site -> + get site "localhost" "/.well-known/acme/x" `shouldReturn` 200 + +---------------------------------------------------------------- + +fileRoute, cgiRoute :: Route +fileRoute = RouteFile "/" "/var/www/" +cgiRoute = RouteCGI "/cgi-bin/" "/var/cgi-bin/" + +db :: RouteDB +db = [Block ["localhost"] [fileRoute], Block ["*"] [cgiRoute]] + +-- | The port of 'fileCgiApp' and a manager shared by requests. +type Site = (Int, H.Manager) + +-- | Running 'fileCgiApp' on a temporary document root. +withSite :: (Site -> IO ()) -> IO () +withSite body = do + tmp <- getTemporaryDirectory + let root = tmp "mighty-waiapp-spec" + bracket (mkSite root) removeDirectoryRecursive $ \_ -> do + rdr <- newRouteDBRef [Block ["localhost"] [RouteFile "/" (fromString (root ++ "/"))]] + mgr <- H.newManager H.defaultManagerSettings + let cspec = ClassicAppSpec "Test" "/nonexistent/" + filespec = FileAppSpec "index.html" (".html" `isSuffixOf`) + cgispec = CgiAppSpec "index.cgi" + app = fileCgiApp cspec filespec cgispec (RevProxyAppSpec mgr) rdr + testWithApplication (return app) $ \port -> body (port, mgr) + where + mkSite root = do + removePathForcibly root + createDirectoryIfMissing True $ root ".git" + createDirectoryIfMissing True $ root ".well-known" "acme" + writeFile (root "index.html") "top\n" + writeFile (root ".git" "config") "secret\n" + writeFile (root ".well-known" "acme" "x") "token\n" + return root + +-- | Sending GET with the Host header and the raw path. +get :: Site -> ByteString -> ByteString -> IO Int +get (port, mgr) host path = do + req <- H.parseRequest $ "http://127.0.0.1:" ++ show port + let req' = req{H.path = path, H.requestHeaders = [("Host", host)]} + statusCode' . H.responseStatus <$> H.httpLbs req' mgr + where + statusCode' :: Status -> Int + statusCode' = statusCode diff --git a/utils/mkindex.hs b/utils/mkindex.hs --- a/utils/mkindex.hs +++ b/utils/mkindex.hs @@ -6,6 +6,12 @@ import Control.Applicative #endif import Data.Bits +import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit) +import Data.List (sort) +import Data.Word (Word8) +import Foreign.Storable (peekByteOff) +import qualified GHC.Foreign as GHC +import GHC.IO.Encoding (getFileSystemEncoding) import Data.Time (formatTime) import Data.Time.Clock.POSIX import System.Directory @@ -31,18 +37,44 @@ mkContents :: IO String mkContents = do - fileNames <- filter dotAndIndex <$> getDirectoryContents "." + fileNames <- sort . filter dotAndIndex <$> getDirectoryContents "." stats <- mapM getFileStatus fileNames - let fmsls = zipWith pp fileNames stats - maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls + hrefs <- mapM toHref fileNames + let fmsls = zipWith3 pp fileNames hrefs stats + maxLen = maximum $ map (\(_,_,_,_,x) -> x) fmsls contents = concatMap (content maxLen) fmsls return contents where - dotAndIndex x = head x /= '.' && x /= indexFile + dotAndIndex x = take 1 x /= "." && x /= indexFile -pp :: String -> FileStatus -> (String,String,String,Int) -pp f st = (file,mtime,size,flen) +-- | Percent-encoding the bytes of a file name for href. +toHref :: String -> IO String +toHref f = do + enc <- getFileSystemEncoding + GHC.withCStringLen enc f $ \(p, n) -> do + bytes <- mapM (\i -> peekByteOff p i) [0 .. n - 1] + return $ concatMap escape (bytes :: [Word8]) where + escape w + | unreserved c = [c] + | otherwise = printf "%%%02X" w + where + c = chr $ fromIntegral w + unreserved c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` "-._~" + +htmlEscape :: String -> String +htmlEscape = concatMap esc + where + esc '&' = "&" + esc '<' = "<" + esc '>' = ">" + esc '"' = """ + esc '\'' = "'" + esc c = [c] + +pp :: String -> String -> FileStatus -> (String,String,String,String,Int) +pp f href st = (htmlEscape file,ppFile href st,mtime,size,flen) + where file = ppFile f st flen = length file mtime = ppMtime st @@ -92,8 +124,8 @@
\n\ 
\n"
 
-content :: Int -> (String,String,String,Int) -> String
-content lim (f,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"
+content :: Int -> (String,String,String,String,Int) -> String
+content lim (f,h,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"
 
 tailer :: String
 tailer = "\
diff --git a/utils/restart.sh b/utils/restart.sh
--- a/utils/restart.sh
+++ b/utils/restart.sh
@@ -21,4 +21,11 @@
 # % sudo certbot renew --webroot -w /usr/local/mighty/webroot --deploy-hook /usr/local/mighty/restart.sh
 
 ${MIGHTY_PATH}/mightyctl retire
-${MIGHTY_PATH}/mighty ${MIGHTY_PATH}/conf ${MIGHTY_PATH}/route +RTS -N2
+
+# The retiring mighty may hold the port for a while.
+# mighty exits with failure if it cannot bind the port.
+for i in 1 2 3 4 5 6 7 8 9 10; do
+    ${MIGHTY_PATH}/mighty ${MIGHTY_PATH}/conf ${MIGHTY_PATH}/route +RTS -N2 && exit 0
+    sleep 1
+done
+exit 1