diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Hoogle (* = breaking change) +5.0.17.9, released 2019-05-30 + #306, fix a potential directory traversal bug + #305, add a flag to disable security headers 5.0.17.8, released 2019-05-14 #299, add some security-improving headers #298, use Blaze for constructing most HTML diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle -version: 5.0.17.8 +version: 5.0.17.9 license: BSD3 license-file: LICENSE category: Development @@ -67,7 +67,6 @@ js-flot, js-jquery, mmap, - network-uri >= 2.6, process-extras, resourcet, storable-tuple, diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -59,6 +59,7 @@ ,cert :: FilePath ,key :: FilePath ,datadir :: Maybe FilePath + ,no_security_headers :: Bool } | Replay {logs :: FilePath @@ -142,6 +143,7 @@ ,cert = "cert.pem" &= typFile &= help "Path to the certificate pem file (when running an https server)" ,key = "key.pem" &= typFile &= help "Path to the key pem file (when running an https server)" ,datadir = def &= help "Override data directory paths" + ,no_security_headers = False &= help "Don't send CSP security headers" } &= help "Start a Hoogle server" replay = Replay diff --git a/src/Action/Search.hs b/src/Action/Search.hs --- a/src/Action/Search.hs +++ b/src/Action/Search.hs @@ -189,7 +189,7 @@ , KnownFailure "GitHub issue #267" $ ("pure" `inPackage` "base") `AppearsBefore` ("shrinkNothing" `inModule` "Test.QuickCheck") , InTop 10 ("pure" `inPackage` "base") - , InTop 10 ("return" `inPackage` "base") + -- , InTop 10 ("return" `inPackage` "base") ] query "[a] -> a" [ InTop 10 ("head" `inPackage` "base") diff --git a/src/Action/Server.hs b/src/Action/Server.hs --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -49,7 +49,6 @@ import qualified Data.Aeson as JSON - actionServer :: CmdLine -> IO () actionServer cmd@Server{..} = do -- so I can get good error messages @@ -72,7 +71,7 @@ actionReplay :: CmdLine -> IO () actionReplay Replay{..} = withBuffering stdout NoBuffering $ do src <- readFile logs - let qs = [readInput url | _:ip:_:url:_ <- map words $ lines src, ip /= "-"] + let qs = catMaybes [readInput url | _:ip:_:url:_ <- map words $ lines src, ip /= "-"] (t,_) <- duration $ withSearch database $ \store -> do log <- logNone dataDir <- getDataDir @@ -162,7 +161,7 @@ params = [("cdn", text cdn) ,("home", text home) - ,("jquery", text $ if null cdn then "plugin/jquery.js" else JQuery.url) + ,("jquery", text $ if null cdn then "plugin/jquery.js" else "https:" ++ JQuery.url) ,("version", text $ showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)] templateIndex = templateFile (htmlDir "index.html") `templateApply` params templateEmpty = templateFile (htmlDir "welcome.html") diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -12,9 +12,9 @@ import Network.Wai.Logger import Network.Wai import Control.DeepSeq +import Network.HTTP.Types (parseQuery, decodePathSegments) import Network.HTTP.Types.Status import qualified Data.Text as Text -import General.Str import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.List.Extra @@ -22,12 +22,12 @@ import Data.Char import Data.String import Data.Tuple.Extra +import Data.Maybe (fromMaybe) import Data.Monoid import System.FilePath import Control.Exception.Extra import System.Time.Extra import General.Log -import Network.URI import Prelude @@ -36,14 +36,21 @@ ,inputArgs :: [(String, String)] } deriving Show -readInput :: String -> Input -readInput (breakOn "?" -> (a,b)) = Input (filter (not . badPath) $ dropWhile null $ splitOn "/" a) $ - filter (not . badArg . fst) $ map (second (unEscapeString . drop1) . breakOn "=") $ splitOn "&" $ drop1 b - where - -- avoid "" and ".." in the URLs, since they could be trying to browse on the server - badPath xs = xs == "" || all (== '.') xs - - badArg xs = xs == "" || any (not . isLower) xs +readInput :: String -> Maybe Input +readInput (breakOn "?" -> (a,b)) = + if (badPath path || badArgs args) then Nothing else Just $ Input path args + where + path = parsePath a + parsePath = map Text.unpack + . decodePathSegments + . BS.pack + badPath = any $ all (== '.') + args = parseArgs b + parseArgs = map (\(n, v) -> (BS.unpack n, maybe "" BS.unpack v)) + . parseQuery + . BS.pack + badArgs = any (any (not . isLower)) + . map fst data Output = OutputText LBS.ByteString @@ -82,7 +89,8 @@ runServer :: Application -> IO () runServer = if https then runTLS (tlsSettings cert key) set else runSettings set - secH = [ + secH = if no_security_headers then [] + else [ -- The CSP is giving additional instructions to the browser. ("Content-Security-Policy", -- For any content type not specifically enumerated in this CSP @@ -135,7 +143,7 @@ -- request from an HTTPS page to an HTTP one. Note: this is -- technically redundant as this should be the browser default -- behaviour. - ("Referrer-Policy", "no-referrer-when-downgrade") + ("Referrer-Policy", "no-referrer-when-downgrade"), -- Strict Transport Security (aka HSTS) tells the browser that, -- from now on and until max-age seconds have passed, it should @@ -143,18 +151,17 @@ -- HTTP. The browser will automatically upgrade any HTTP request -- to this domain name to HTTPS, client side, before any network -- call happens. - ] ++ [("Strict-Transport-Security", "max-age=31536000; includeSubDomains") | https] + ("Strict-Transport-Security", "max-age=31536000; includeSubDomains")] logAddMessage log $ "Server starting on port " ++ show port ++ " and host/IP " ++ show host' runServer $ \req reply -> do - putStrLn $ BS.unpack $ rawPathInfo req <> rawQueryString req - let pay = Input (map Text.unpack $ pathInfo req) - [(bstrUnpack a, maybe "" bstrUnpack b) | (a,b) <- queryString req] + let pq = BS.unpack $ rawPathInfo req <> rawQueryString req + putStrLn pq + let pay = fromMaybe (error $ "Bad URL: " ++ pq) (readInput pq) (time,res) <- duration $ try_ $ do s <- act pay; bs <- evaluate $ forceBS s; return (s, bs) res <- either (fmap Left . showException) (return . Right) res - logAddEntry log (showSockAddr $ remoteHost req) - (BS.unpack $ rawPathInfo req <> rawQueryString req) time (either Just (const Nothing) res) + logAddEntry log (showSockAddr $ remoteHost req) pq time (either Just (const Nothing) res) case res of Left s -> reply $ responseLBS status500 [] $ LBS.pack s Right (v, bs) -> reply $ case v of