diff --git a/datadir/resources/hoogle.js b/datadir/resources/hoogle.js --- a/datadir/resources/hoogle.js +++ b/datadir/resources/hoogle.js @@ -199,16 +199,25 @@ ///////////////////////////////////////////////////////////////////// // SEARCH PLUGIN +var prefixUrl = document.location.protocol + "//" + document.location.hostname + document.location.pathname; + $(function(){ if (embed) return; + if (prefixUrl != "http://haskell.org/hoogle/") + { + $("link[rel=search]").attr("href", function(){ + return this.href + "?domain=" + escape(prefixUrl); + }); + } if (window.external && ("AddSearchProvider" in window.external)) $("#plugin").css("display",""); }); function searchPlugin() { - var l = document.location; - var url = l.protocol + "//" + l.hostname + l.pathname + $("link[rel=search]").attr("href"); + var url = $("link[rel=search]").attr("href"); + if (url.substring(0, prefixUrl.length) != prefixUrl) + url = prefixUrl + url; window.external.AddSearchProvider(url); } diff --git a/datadir/resources/search.xml b/datadir/resources/search.xml new file mode 100644 --- /dev/null +++ b/datadir/resources/search.xml @@ -0,0 +1,21 @@ + + + Hoogle + Hoogle - Haskell API Search + + 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. + + haskell + + + + http://haskell.org/hoogle/datadir/resources/favicon.png + http://haskell.org/hoogle/datadir/resources/favicon64.png + Neil Mitchell + false + en-us + UTF-8 + UTF-8 + diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hoogle -version: 4.2.7 +version: 4.2.8 license: GPL license-file: docs/LICENSE category: Development @@ -28,6 +28,7 @@ -- Cabal doesn't find files with . in them, Cabal bug #794 resources/jquery-1.4.2.js resources/jquery.cookie.js + resources/search.xml source-repository head type: darcs @@ -100,6 +101,7 @@ Hoogle.Store.ReadBuffer Hoogle.Store.Type Hoogle.Store.WriteBuffer + Paths_hoogle executable hoogle main-is: Main.hs @@ -107,12 +109,12 @@ build-depends: time, old-time, old-locale, - cmdargs >= 0.7 && < 0.9, + cmdargs >= 0.7 && < 0.10, tagsoup >= 0.11 && < 0.13, enumerator == 0.4.*, blaze-builder >= 0.2 && < 0.4, http-types == 0.6.*, - case-insensitive >= 0.2 && < 0.4, + case-insensitive >= 0.2 && < 0.5, wai == 0.4.*, warp == 0.4.*, Cabal >= 1.8 && < 1.13 diff --git a/src/CmdLine/All.hs b/src/CmdLine/All.hs --- a/src/CmdLine/All.hs +++ b/src/CmdLine/All.hs @@ -70,9 +70,11 @@ guessLocal = do ghc <- findExecutable "ghc" + home <- getHomeDirectory lib <- getLibDir - let xs = [takeDirectory (takeDirectory lib) "doc"] ++ - [takeDirectory (takeDirectory ghc) "doc/html/libraries" | Just ghc <- [ghc]] + let xs = [takeDirectory (takeDirectory lib) "doc" {- Windows, installed with Cabal -} ] ++ + [takeDirectory (takeDirectory ghc) "doc/html/libraries" | Just ghc <- [ghc] {- Windows, installed by GHC -} ] ++ + [home ".cabal/share/doc" {- Linux -} ] filterM doesDirectoryExist xs diff --git a/src/General/Base.hs b/src/General/Base.hs --- a/src/General/Base.hs +++ b/src/General/Base.hs @@ -32,6 +32,20 @@ bsUnpack = BS.unpack +bsReplace :: BString -> BString -> BString -> BString +bsReplace find rep = BS.concat . f + where + nfind = BS.length find + + f x | BS.null b = [a] + | otherwise = a : rep : f (BS.drop nfind b) + where (a,b) = BS.breakSubstring find x + +lbsReplace :: LBString -> LBString -> LBString -> LBString +lbsReplace find rep x = LBS.fromChunks [bsReplace (f find) (f rep) (f x)] + where f = BS.concat . LBS.toChunks + + -- | A URL, or internet address. These addresses will usually start with either -- @http:\/\/@ or @file:\/\/@. type URL = String diff --git a/src/General/System.hs b/src/General/System.hs --- a/src/General/System.hs +++ b/src/General/System.hs @@ -42,8 +42,8 @@ withModeGlobalRead :: IO () -> IO () withModeGlobalRead act = E.bracket (setFileCreationMask 0o022) - (const act) (\x -> setFileCreationMask x >> return ()) + (const act) -- FIXME: This could use a lot more bracket calls! diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -6,7 +6,7 @@ module General.Web( responseOK, responseNotFound, - responseFlatten, responseEvaluate, + responseFlatten, responseEvaluate, responseRewrite, URL, filePathToURL, combineURL, escapeURL, (++%), unescapeURL, escapeHTML, (++&), htmlTag, Args, cgiArgs, cgiResponse, parseHttpQueryArgs @@ -40,6 +40,12 @@ responseEvaluate :: Response -> IO () responseEvaluate (ResponseBuilder _ _ x) = LBS.length (toLazyByteString x) `seq` return () responseEvaluate _ = return () + + +responseRewrite :: (LBString -> LBString) -> Response -> IO Response +responseRewrite f r = do + (a,b,c) <- responseFlatten r + return $ responseLBS a b $ f c --------------------------------------------------------------------- diff --git a/src/Web/Server.hs b/src/Web/Server.hs --- a/src/Web/Server.hs +++ b/src/Web/Server.hs @@ -18,8 +18,6 @@ import Network.Wai import Network.Wai.Handler.Warp -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.ByteString.Char8 as BS server :: CmdLine -> IO () @@ -82,19 +80,30 @@ -- FIXME: Avoid all the conversions to/from LBS talk :: IO ResponseArgs -> CmdLine -> Request -> IO Response -talk resp Server{..} Request{rawPathInfo=path_, rawQueryString=query_} +talk resp Server{..} r@Request{rawPathInfo=path_, rawQueryString=query_} | path `elem` ["/","/hoogle"] = do let args = parseHttpQueryArgs $ drop 1 query cmd <- cmdLineWeb args resp <- resp r <- response resp cmd{databases=databases} if local_ then rewriteFileLinks r else return r + | path == "/res/search.xml" = serveSearch resources (fmap bsUnpack $ join $ lookup (fromString "domain") $ queryString r) | takeDirectory path == "/res" = serveFile True $ resources takeFileName path - | local_ && "/file/" `isPrefixOf` path = serveFile False $ drop 6 path + | local_, Just path <- stripPrefix "/file/" path = + let hasDrive = "/" `isPrefixOf` path && ":" `isPrefixOf` (drop 2 path) + in serveFile False $ if hasDrive then drop 1 path else path | otherwise = return $ responseNotFound $ show path where (path,query) = (bsUnpack path_, bsUnpack query_) +serveSearch :: FilePath -> Maybe String -> IO Response +serveSearch resources domain = do + r <- serveFile True $ resources "search.xml" + case domain of + Nothing -> return r + Just x -> responseRewrite (lbsReplace (fromString "http://haskell.org/hoogle/") (fromString x)) r + + serveFile :: Bool -> FilePath -> IO Response serveFile cache file = do b <- doesFileExist file @@ -106,18 +115,7 @@ rewriteFileLinks :: Response -> IO Response -rewriteFileLinks r = do - (a,b,c) <- responseFlatten r - let res = LBS.fromChunks $ f $ BS.concat $ LBS.toChunks c - return $ responseLBS a b res - where - f x | BS.null b = [a] - | otherwise = a : rep : f (BS.drop nfind b) - where (a,b) = BS.breakSubstring find x - - find = fromString "href='file://" - rep = fromString "href='/file/" - nfind = BS.length find +rewriteFileLinks = responseRewrite $ lbsReplace (fromString "href='file://") (fromString "href='/file/") contentExt ".png" = "image/png" @@ -125,4 +123,5 @@ contentExt ".js" = "text/javascript" contentExt ".html" = "text/html" contentExt ".htm" = "text/html" +contentExt ".xml" = "application/opensearchdescription+xml" contentExt _ = "text/plain"