diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,5 +1,11 @@
Changelog for Hoogle (* = breaking change)
+5.0.17.10, released 2019-08-02
+ #314, fix bad URL trying to access package on Hoogle with --local
+ #311, fix an overflow with weight computations
+ Fix up the /log page to avoid raising CSP errors
+ Avoid raising error when you see a bad URL
+ Make errors from the server be code 400 rather than 500
5.0.17.9, released 2019-05-30
#306, fix a potential directory traversal bug
#305, add a flag to disable security headers
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.9
+version: 5.0.17.10
license: BSD3
license-file: LICENSE
category: Development
@@ -13,7 +13,7 @@
Hoogle is a Haskell API search engine, which allows you to
search many standard Haskell libraries by either function name,
or by approximate type signature.
-homepage: http://hoogle.haskell.org/
+homepage: https://hoogle.haskell.org/
bug-reports: https://github.com/ndmitchell/hoogle/issues
tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2
extra-doc-files:
diff --git a/html/log.html b/html/log.html
--- a/html/log.html
+++ b/html/log.html
@@ -6,53 +6,13 @@
+
-
-
diff --git a/html/log.js b/html/log.js
new file mode 100644
--- /dev/null
+++ b/html/log.js
@@ -0,0 +1,38 @@
+var data = #{data};
+function series(name, val)
+{
+ val.label = name;
+ val.data = [];
+ for (var i = 0; i < data.length; i++)
+ {
+ var x = data[i][name.toLowerCase()];
+ val.data.push([new Date(data[i].date),x == 0 ? null : x]);
+ }
+ return val;
+}
+$(function(){
+ var settings =
+ {series: {lines: {show: true}, points: {show: true}}
+ ,xaxis: {mode: "time", minTickSize: [1, "day"]}
+ ,yaxes: [{}, {position: "right"}]
+ ,grid: {hoverable: true, clickable: true}};
+ $.plot("#users",[series("Uses",{yaxis:2}),series("Users",{})], settings);
+ $.plot("#timings",[series("Average",{}),series("Slowest",{yaxis:2})], settings);
+ settings.series.lines.show = false;
+ $.plot("#errors",[series("Errors",{color:"darkred"})], settings);
+
+ $(".plot").bind("plothover", function (event, pos, item) {
+ if (item) {
+ var x = new Date(item.datapoint[0]).toDateString();
+ var y = item.datapoint[1];
+ y = Math.floor(y) == y ? y : y.toFixed(3);
+
+ $("#tooltip").html(y + " = " + item.series.label + " on " + x)
+ .css({top: item.pageY+5, left: item.pageX+5})
+ .fadeIn(200);
+ } else {
+ $("#tooltip").hide();
+ }
+ });
+
+});
diff --git a/html/search.xml b/html/search.xml
--- a/html/search.xml
+++ b/html/search.xml
@@ -8,11 +8,11 @@
or by approximate type signature.
haskell
-
-
+
+
- http://hoogle.haskell.org/favicon.png
- http://hoogle.haskell.org/favicon64.png
+ https://hoogle.haskell.org/favicon.png
+ https://hoogle.haskell.org/favicon64.png
Neil Mitchell
false
en-us
diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs
--- a/src/Action/CmdLine.hs
+++ b/src/Action/CmdLine.hs
@@ -104,7 +104,7 @@
cmdLineMode = cmdArgsMode $ modes [search_ &= auto,generate,server,replay,test]
&= verbosity &= program "hoogle"
- &= summary ("Hoogle " ++ showVersion version ++ ", http://hoogle.haskell.org/")
+ &= summary ("Hoogle " ++ showVersion version ++ ", https://hoogle.haskell.org/")
search_ = Search
{color = def &= name "colour" &= help "Use colored output (requires ANSI terminal)"
@@ -137,7 +137,7 @@
,haddock = def &= help "Serve local haddocks from a specified directory"
,scope = def &= help "Default scope to start with"
,links = def &= help "Display extra links"
- ,home = "http://hoogle.haskell.org" &= typ "URL" &= help "Set the URL linked to by the Hoogle logo."
+ ,home = "https://hoogle.haskell.org" &= typ "URL" &= help "Set the URL linked to by the Hoogle logo."
,host = "" &= help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host)."
,https = def &= help "Start an https server (use --cert and --key to specify paths to the .pem files)"
,cert = "cert.pem" &= typFile &= help "Path to the certificate pem file (when running an https server)"
diff --git a/src/Action/Search.hs b/src/Action/Search.hs
--- a/src/Action/Search.hs
+++ b/src/Action/Search.hs
@@ -253,10 +253,8 @@
query "(a -> b) -> Maybe a -> Maybe b"
[ InTop 3 ("fmap" `inPackage` "base")
]
- query "IO a -> m a" -- see GitHub issue #180
- [ InTop 50 ("liftIO" `inPackage` "base")
- , KnownFailure "GitHub issue #180" $
- InTop 3 ("liftIO" `inPackage` "base")
+ query "IO a -> m a"
+ [ InTop 3 ("liftIO" `inPackage` "base")
]
query "a -> m a" -- see GitHub issue #180
[ InTop 20 ("pure" `inPackage` "base")
diff --git a/src/Action/Server.hs b/src/Action/Server.hs
--- a/src/Action/Server.hs
+++ b/src/Action/Server.hs
@@ -131,8 +131,10 @@
"Updates " ++ (if alive < 1.5 then "good" else "bad") ++ ": Last updated " ++ showDP 2 alive ++ " days ago.\n"
["log"] -> do
+ OutputHTML <$> templateRender templateLog []
+ ["log.js"] -> do
log <- displayLog <$> logSummary log
- OutputHTML <$> templateRender templateLog [("data",html $ H.string log)]
+ OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log)]
["stats"] -> do
stats <- getStatsDebug
return $ case stats of
@@ -167,6 +169,7 @@
templateEmpty = templateFile (htmlDir "welcome.html")
templateHome = templateIndex `templateApply` [("tags",html $ tagOptions []),("body",templateEmpty),("title",text "Hoogle"),("search",text ""),("robots",text "index")]
templateLog = templateFile (htmlDir "log.html") `templateApply` params
+ templateLogJs = templateFile (htmlDir "log.js") `templateApply` params
dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]]
diff --git a/src/General/Log.hs b/src/General/Log.hs
--- a/src/General/Log.hs
+++ b/src/General/Log.hs
@@ -112,7 +112,7 @@
{-# NOINLINE parseLogLine #-}
parseLogLine :: (BS.ByteString -> Bool) -> BS.ByteString -> Maybe (Day, SummaryI)
parseLogLine interesting (BS.words -> time:user:dur:query:err)
- | use && not isErr
+ | use || isErr
, user /= BS.singleton '-'
, Just [a, b, c] <- fmap (map fst) $ mapM BS.readInt $ BS.split '-' $ BS.takeWhile (/= 'T') time
= Just (fromGregorian (fromIntegral a) b c, SummaryI
diff --git a/src/General/Util.hs b/src/General/Util.hs
--- a/src/General/Util.hs
+++ b/src/General/Util.hs
@@ -366,7 +366,7 @@
add mp x
| Just x2 <- Map.lookupLE (fst x) mp, overlap x x2 = add (Map.delete (fst x2) mp) (merge x x2)
| Just x2 <- Map.lookupGE (fst x) mp, overlap x x2 = add (Map.delete (fst x2) mp) (merge x x2)
- | otherwise = Map.insert (fst x) (snd x) mp
+ | otherwise = uncurry Map.insert x mp
general_util_test :: IO ()
diff --git a/src/General/Web.hs b/src/General/Web.hs
--- a/src/General/Web.hs
+++ b/src/General/Web.hs
@@ -22,7 +22,7 @@
import Data.Char
import Data.String
import Data.Tuple.Extra
-import Data.Maybe (fromMaybe)
+import Data.Maybe
import Data.Monoid
import System.FilePath
import Control.Exception.Extra
@@ -44,7 +44,7 @@
parsePath = map Text.unpack
. decodePathSegments
. BS.pack
- badPath = any $ all (== '.')
+ badPath = any (all (== '.')) . filter (/= "")
args = parseArgs b
parseArgs = map (\(n, v) -> (BS.unpack n, maybe "" BS.unpack v))
. parseQuery
@@ -55,6 +55,7 @@
data Output
= OutputText LBS.ByteString
| OutputHTML LBS.ByteString
+ | OutputJavascript LBS.ByteString
| OutputJSON Encoding
| OutputFail LBS.ByteString
| OutputFile FilePath
@@ -65,6 +66,7 @@
forceBS (OutputText x) = force x
forceBS (OutputJSON x) = force $ encodingToLazyByteString x
forceBS (OutputHTML x) = force x
+forceBS (OutputJavascript x) = force x
forceBS (OutputFail x) = force x
forceBS (OutputFile x) = rnf x `seq` LBS.empty
@@ -158,9 +160,11 @@
runServer $ \req reply -> do
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
+ (time, res) <- duration $ case readInput pq of
+ Nothing -> return $ Right (OutputFail "", LBS.pack $ "Bad URL: " ++ pq)
+ Just pay ->
+ handle_ (fmap Left . showException) $ do
+ s <- act pay; bs <- evaluate $ forceBS s; return $ Right (s, bs)
logAddEntry log (showSockAddr $ remoteHost req) pq time (either Just (const Nothing) res)
case res of
Left s -> reply $ responseLBS status500 [] $ LBS.pack s
@@ -169,7 +173,8 @@
([("content-type",c) | Just c <- [lookup (takeExtension file) contentType]] ++ secH) file Nothing
OutputText{} -> responseLBS status200 (("content-type","text/plain") : secH) bs
OutputJSON{} -> responseLBS status200 (("content-type","application/json") : ("access-control-allow-origin","*") : secH) bs
- OutputFail{} -> responseLBS status500 (("content-type","text/plain") : secH) bs
+ OutputFail{} -> responseLBS status400 (("content-type","text/plain") : secH) bs
OutputHTML{} -> responseLBS status200 (("content-type","text/html") : secH) bs
+ OutputJavascript{} -> responseLBS status200 (("content-type","text/javascript") : secH) bs
contentType = [(".html","text/html"),(".css","text/css"),(".js","text/javascript")]
diff --git a/src/Output/Types.hs b/src/Output/Types.hs
--- a/src/Output/Types.hs
+++ b/src/Output/Types.hs
@@ -314,7 +314,7 @@
where
-- CAFs must match perfectly, otherwise too many is better than too few
arity | ta == 0 = \ca -> if ca == 0 then mfpJust $ mfpCost "arity equal" 0 else mfpMiss "arity different and query a CAF" -- searching for a CAF
- | otherwise = \ca -> case fromIntegral $ ca - ta of
+ | otherwise = \ca -> case fromIntegral ca - fromIntegral ta of
_ | ca == 0 -> mfpMiss "arity different and answer a CAF" -- searching for a CAF
0 -> mfpJust $ mfpCost "arity equal" 0 -- perfect match
-1 -> mfpJust $ mfpCost "arity 1 to remove" 1000 -- not using something the user carefully wrote
@@ -327,7 +327,7 @@
allowMore = TVar name0 [] `elem` sigTy sig
-- missing terms are a bit worse than invented terms, but it's fairly balanced, clip at large numbers
- terms = \ct -> case fromIntegral $ ct - tt of
+ terms = \ct -> case fromIntegral ct - fromIntegral tt of
n | abs n > 20 -> mfpMiss $ "terms " ++ show n ++ " different" -- too different
| n == 0 -> mfpJust $ mfpCost "terms equal" 0
| n > 0 -> mfpJust $ mfpCost ("terms " ++ show n ++ " to add") $ n * 10 -- candidate has more terms
@@ -348,7 +348,7 @@
differences :: Double -> Double -> Fingerprint -> Fingerprint -> a
differences !rare !common !want !have = fpRaresFold mfpAdd f want
where f n | fpRaresElem n have = mfpCost ("term in common " ++ prettyName n) 0
- | n == name0 = mfpCost ("term _ missing") $ floor rare -- should this be common?
+ | n == name0 = mfpCost "term _ missing" 0 -- will pay the cost the other way around
| otherwise = let p = popularityName n in mfpCost ("term " ++ prettyName n ++ " (" ++ showDP 2 p ++ ") missing") $
floor $ (p*common) + ((1-p)*rare)