hoogle 5.0.17.8 → 5.0.17.9
raw patch · 6 files changed
+34/−24 lines, 6 filesdep −network-uriPVP ok
version bump matches the API change (PVP)
Dependencies removed: network-uri
API changes (from Hackage documentation)
Files
- CHANGES.txt +3/−0
- hoogle.cabal +1/−2
- src/Action/CmdLine.hs +2/−0
- src/Action/Search.hs +1/−1
- src/Action/Server.hs +2/−3
- src/General/Web.hs +25/−18
CHANGES.txt view
@@ -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
hoogle.cabal view
@@ -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,
src/Action/CmdLine.hs view
@@ -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
src/Action/Search.hs view
@@ -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")
src/Action/Server.hs view
@@ -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")
src/General/Web.hs view
@@ -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