mighttpd2 4.0.10 → 4.0.11
raw patch · 14 files changed
+394/−65 lines, 14 filesdep ~waidep ~wai-app-file-cgiPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: wai, wai-app-file-cgi
API changes (from Hackage documentation)
+ Program.Mighty.Route: normalizeDomain :: Domain -> Domain
Files
- Program/Mighty/Config.hs +45/−7
- Program/Mighty/Parser.hs +2/−2
- Program/Mighty/Process.hs +3/−6
- Program/Mighty/Report.hs +41/−14
- Program/Mighty/Resource.hs +10/−4
- Program/Mighty/Route.hs +19/−1
- mighttpd2.cabal +16/−4
- src/Server.hs +16/−9
- src/WaiApp.hs +27/−9
- test/ConfigSpec.hs +20/−0
- test/ReportSpec.hs +39/−0
- test/WaiAppSpec.hs +108/−0
- utils/mkindex.hs +40/−8
- utils/restart.sh +8/−1
Program/Mighty/Config.hs view
@@ -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 ----------------------------------------------------------------
Program/Mighty/Parser.hs view
@@ -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 --
Program/Mighty/Process.hs view
@@ -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
Program/Mighty/Report.hs view
@@ -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
Program/Mighty/Resource.hs view
@@ -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
Program/Mighty/Route.hs view
@@ -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
mighttpd2.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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:
src/Server.hs view
@@ -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
src/WaiApp.hs view
@@ -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
test/ConfigSpec.hs view
@@ -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 =
+ test/ReportSpec.hs view
@@ -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
+ test/WaiAppSpec.hs view
@@ -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
utils/mkindex.hs view
@@ -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 @@ <hr>\n\ <pre>\n" -content :: Int -> (String,String,String,Int) -> String-content lim (f,m,s,len) = "<a href=\"" ++ f ++ "\">" ++ f ++ "</a> " ++ replicate (lim - len) ' ' ++ m ++ " " ++ s ++ "\n"+content :: Int -> (String,String,String,String,Int) -> String+content lim (f,h,m,s,len) = "<a href=\"./" ++ h ++ "\">" ++ f ++ "</a> " ++ replicate (lim - len) ' ' ++ m ++ " " ++ s ++ "\n" tailer :: String tailer = "\
utils/restart.sh view
@@ -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