hoogle 5.0.17.6 → 5.0.17.7
raw patch · 10 files changed
+107/−61 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES.txt +4/−0
- hoogle.cabal +2/−2
- src/Action/Search.hs +7/−6
- src/Action/Server.hs +38/−32
- src/General/Store.hs +9/−8
- src/General/Util.hs +6/−4
- src/General/Web.hs +34/−6
- src/Input/Cabal.hs +2/−1
- src/Input/Download.hs +2/−1
- src/Input/Haddock.hs +3/−1
CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for Hoogle (* = breaking change) +5.0.17.7, released 2019-05-10+ Fix an XSS vulnerability, reported by @alexanderGugel+ #297, make Uses for packages point at reverse deps+ #261, add support for pattern synonyms 5.0.17.6, released 2019-03-27 #291, optimise the log parsing (5x speedup) #289, change to use autofocus attribute
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle-version: 5.0.17.6+version: 5.0.17.7 license: BSD3 license-file: LICENSE category: Development@@ -15,7 +15,7 @@ or by approximate type signature. homepage: http://hoogle.haskell.org/ bug-reports: https://github.com/ndmitchell/hoogle/issues-tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2+tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 extra-doc-files: README.md CHANGES.txt
src/Action/Search.hs view
@@ -9,6 +9,7 @@ import Control.DeepSeq import Control.Monad.Extra+import Control.Exception.Extra import Data.Functor.Identity import Data.List.Extra import qualified Data.Map as Map@@ -99,12 +100,12 @@ res <- return $ snd $ search store (parseQuery a) case res of [] -> putChar '.'- _ -> error $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res) ++ "\n expected none"+ _ -> errorIO $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res) ++ "\n expected none" let a ==$ f = do res <- return $ snd $ search store (parseQuery a) case res of Target{..}:_ | f targetURL -> putChar '.'- _ -> error $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res)+ _ -> errorIO $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res) let a === b = a ==$ (== b) let query :: String -> [ExpectedQueryResult] -> IO ()@@ -112,9 +113,9 @@ in forM_ qrs $ \qr -> case matchQR qr results of Success -> putChar '.' ExpectedFailure -> putChar 'o'- _ -> error $ "Searching for: " ++ show a- ++ "\nGot: " ++ show (take 5 results)- ++ "\n expected " ++ expected qr+ _ -> errorIO $ "Searching for: " ++ show a+ ++ "\nGot: " ++ show (take 5 results)+ ++ "\n expected " ++ expected qr let hackage x = "https://hackage.haskell.org/package/" ++ x if sample then do@@ -280,7 +281,7 @@ ] let tags = completionTags store- let asserts b x = if b then putChar '.' else error $ "Assertion failed, got False for " ++ x+ let asserts b x = if b then putChar '.' else errorIO $ "Assertion failed, got False for " ++ x asserts ("set:haskell-platform" `elem` tags) "set:haskell-platform `elem` tags" asserts ("author:Neil-Mitchell" `elem` tags) "author:Neil-Mitchell `elem` tags" asserts ("package:uniplate" `elem` tags) "package:uniplate `elem` tags"
src/Action/Server.hs view
@@ -5,6 +5,7 @@ import Data.List.Extra import System.FilePath import Control.Exception+import Control.Exception.Extra import Control.DeepSeq import System.Directory import Data.Tuple.Extra@@ -83,34 +84,33 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = case inputURL of -- without -fno-state-hack things can get folded under this lambda [] -> do- let grab name = [x | (a,x) <- inputArgs, a == name, x /= ""]- let qScope = let xs = grab "scope" in [scope | null xs && scope /= ""] ++ xs- let qSource = grab "hoogle" ++ filter (/= "set:stackage") qScope- let q = concatMap parseQuery qSource- let (q2, results) = search store q+ let grab name = [x | (a,x) <- inputArgs, a == name, x /= taint ""]+ grabInt name def = fromMaybe def $ readMaybe . carefulUntaint =<< listToMaybe (grab name) :: Int++ let qScope = let xs = grab "scope" in [taint scope | null xs && scope /= ""] ++ xs+ let qSource = sequenceA $ grab "hoogle" ++ filter (/= taint "set:stackage") qScope+ let q = concatMap parseQuery <$> qSource :: Taint [Query]+ let (q2, results) = search store $ carefulUntaint q let body = showResults local links haddock (filter ((/= "mode") . fst) inputArgs) q2 $ dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results- case lookup "mode" $ reverse inputArgs of- Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex $ map (second str)+ case lookup "mode" inputArgs of+ Nothing | qSource /= taint [] -> fmap OutputHTML $ templateRender templateIndex $ map (second str) [("tags",tagOptions qScope) ,("body",body)- ,("title",unwords qSource ++ " - Hoogle")- ,("search",unwords $ grab "hoogle")- ,("robots",if any isQueryScope q then "none" else "index")]+ ,("title",escapeUntaint $ (\x -> unwords x ++ " - Hoogle") <$> qSource)+ ,("search",escapeUntaint $ unwords <$> sequenceA (grab "hoogle"))+ ,("robots",if carefulUntaint $ any isQueryScope <$> q then "none" else "index")] | otherwise -> OutputHTML <$> templateRender templateHome []- Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else return $ lbstrPack body- Just "json" ->- let argRead :: Read a => String -> a -> a- argRead key def = fromMaybe def $- readMaybe =<< lookup key inputArgs- -- 1 means don't drop anything, if it's less than 1 ignore it+ Just ((== taint "body") -> True) -> OutputHTML <$> if qSource == taint [] then templateRender templateEmpty [] else return $ lbstrPack body+ Just ((== taint "json") -> True) ->+ let -- 1 means don't drop anything, if it's less than 1 ignore it start :: Int- start = max 0 $ (argRead "start" 1) - 1+ start = max 0 $ grabInt "start" 1 - 1 -- by default it returns 100 entries count :: Int- count = min 500 $ argRead "count" 100+ count = min 500 $ grabInt "count" 100 in pure $ OutputJSON $ JSON.encode $ take count $ drop start results- Just m -> return $ OutputFail $ lbstrPack $ "Mode " ++ m ++ " not (currently) supported"+ Just m -> return $ OutputFail $ lbstrPack $ "Mode " ++ escapeUntaint m ++ " not (currently) supported" ["plugin","jquery.js"] -> OutputFile <$> JQuery.file ["plugin","jquery.flot.js"] -> OutputFile <$> Flot.file Flot.Flot ["plugin","jquery.flot.time.js"] -> OutputFile <$> Flot.file Flot.FlotTime@@ -133,7 +133,7 @@ Nothing -> OutputFail $ lbstrPack "GHC Statistics is not enabled, restart with +RTS -T" Just x -> OutputText $ lbstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x "haddock":xs | Just x <- haddock -> do- let file = intercalate "/" $ filter (not . (== "..")) (x:xs)+ let file = intercalate "/" $ x:xs return $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") "file":xs | local -> do let x = ['/' | not isWindows] ++ intercalate "/" (dropWhile null xs)@@ -146,11 +146,10 @@ -- so replace on file:// and drop all leading empty paths above return $ OutputHTML $ lbstrPack $ replace "file://" "/file/" src xs ->- -- avoid "" and ".." in the URLs, since they could be trying to browse on the server- return $ OutputFile $ joinPath $ htmlDir : filter (not . all (== '.')) xs+ return $ OutputFile $ joinPath $ htmlDir : xs where str = templateStr . lbstrPack- tagOptions sel = concat [tag "option" ["selected=selected" | x `elem` sel] x | x <- completionTags store]+ tagOptions sel = concat [tag "option" ["selected=selected" | taint x `elem` sel] x | x <- completionTags store] params = map (second str) [("cdn",cdn) ,("home",home)@@ -172,7 +171,7 @@ where k = key x -showResults :: Bool -> Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> String+showResults :: Bool -> Bool -> Maybe FilePath -> [(String, Taint String)] -> [Query] -> [[Target]] -> String showResults local links haddock args query results = unlines $ ["<h1>" ++ renderQuery query ++ "</h1>" ,"<ul id=left>"@@ -190,15 +189,18 @@ "</div>" | is@(Target{..}:_) <- results] where- useLink ts@(t:_)=+ useLink :: [Target] -> String+ useLink [t] | isNothing $ targetPackage t =+ "https://packdeps.haskellers.com/reverse/" ++ extractName (targetItem t)+ useLink ts@(t:_) = "https://codesearch.aelve.com/haskell/search?query=" ++ escapeURL (extractName $ targetItem t) ++ "&filter=" ++ intercalate "|" (mapMaybe (fmap fst . targetModule) ts) ++ "&precise=on" - add x = escapeHTML $ ("?" ++) $ intercalate "&" $ map (joinPair "=") $+ add x = ("?" ++) $ intercalate "&" $ map (joinPair "=" . second escapeUntaint) $ case break ((==) "hoogle" . fst) args of- (a,[]) -> a ++ [("hoogle",x)]- (a,(_,x1):b) -> a ++ [("hoogle",x1 ++ " " ++ x)] ++ b+ (a,[]) -> a ++ [("hoogle",taint x)]+ (a,(_,x1):b) -> a ++ [("hoogle",(\v -> v ++ " " ++ x) <$> x1)] ++ b f cat val = "<a class=\"minus\" href=\"" ++ add ("-" ++ cat ++ ":" ++ val) ++ "\"></a>" ++ "<a class=\"plus\" href=\"" ++ add (cat ++ ":" ++ val) ++ "\">" ++@@ -261,7 +263,7 @@ let expand = replace "{" "<b>" . replace "}" "</b>" . replace "<s0>" "" . replace "</s0>" "" contract = replace "{" "" . replace "}" "" let q === s | displayItem (parseQuery q) (contract s) == expand s = putChar '.'- | otherwise = error $ show (q,s,displayItem (parseQuery q) (contract s))+ | otherwise = errorIO $ show (q,s,displayItem (parseQuery q) (contract s)) "test" === "<s0>my{Test}</s0> :: Int -> test" "new west" === "<s0>{newest}_{new}</s0> :: Int" "+*" === "(<s0>{+*}&</s0>) :: Int"@@ -277,9 +279,13 @@ testing "Action.Server.replyServer" $ withSearch database $ \store -> do log <- logNone dataDir <- getDataDir- let q === want = do- OutputHTML (lbstrUnpack -> res) <- replyServer log False False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",q)])- if want `isInfixOf` res then putChar '.' else fail $ "Bad substring: " ++ res+ let check p q = do+ OutputHTML (lbstrUnpack -> res) <- replyServer log False False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",taint q)])+ if p res then putChar '.' else fail $ "Bad substring: " ++ res+ let q === want = check (want `isInfixOf`) q+ let q /== want = check (not . isInfixOf want) q+ "<test" /== "<test"+ "&test" /== "&test" if sample then "Wife" === "<b>type family</b>" else do
src/General/Store.hs view
@@ -12,6 +12,7 @@ import Control.Applicative import Control.DeepSeq import Control.Exception+import Control.Exception.Extra import Control.Monad.Extra import Data.Binary import qualified Data.ByteString.Char8 as BS@@ -117,7 +118,7 @@ -- sort the atoms and validate there are no duplicates let atoms = Map.fromList swAtoms when (Map.size atoms /= length swAtoms) $- error "Some duplicate names have been written out"+ errorIO "Some duplicate names have been written out" -- write the atoms out, then put the size at the end let bs = encodeBS atoms@@ -169,22 +170,22 @@ storeReadFile file act = mmapWithFilePtr file ReadOnly Nothing $ \(ptr, len) -> strict $ do -- check is longer than my version string when (len < (BS.length verString * 2) + intSize) $- error $ "The Hoogle file " ++ file ++ " is corrupt, only " ++ show len ++ " bytes."+ errorIO $ "The Hoogle file " ++ file ++ " is corrupt, only " ++ show len ++ " bytes." let verN = BS.length verString verEnd <- BS.unsafePackCStringLen (plusPtr ptr $ len - verN, verN) when (verString /= verEnd) $ do verStart <- BS.unsafePackCStringLen (plusPtr ptr 0, verN) if verString /= verStart then- error $ "The Hoogle file " ++ file ++ " is the wrong version or format.\n" ++- "Expected: " ++ trim (BS.unpack verString) ++ "\n" ++- "Got : " ++ map (\x -> if isAlphaNum x || x `elem` "_-. " then x else '?') (trim $ BS.unpack verStart)+ errorIO $ "The Hoogle file " ++ file ++ " is the wrong version or format.\n" +++ "Expected: " ++ trim (BS.unpack verString) ++ "\n" +++ "Got : " ++ map (\x -> if isAlphaNum x || x `elem` "_-. " then x else '?') (trim $ BS.unpack verStart) else- error $ "The Hoogle file " ++ file ++ " is truncated, probably due to an error during creation."+ errorIO $ "The Hoogle file " ++ file ++ " is truncated, probably due to an error during creation." atomSize <- intFromBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize, intSize) when (len < verN + intSize + atomSize) $- error $ "The Hoogle file " ++ file ++ " is corrupt, couldn't read atom table."+ errorIO $ "The Hoogle file " ++ file ++ " is corrupt, couldn't read atom table." atoms <- decodeBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize - atomSize, atomSize) act $ StoreRead file len ptr atoms @@ -196,7 +197,7 @@ storeReadAtom StoreRead{..} (typeOf -> k) unpack = unsafePerformIO $ do let key = show k let val = show $ typeOf (undefined :: a)- let corrupt msg = error $ "The Hoogle file " ++ srFile ++ " is corrupt, " ++ key ++ " " ++ msg ++ "."+ let corrupt msg = errorIO $ "The Hoogle file " ++ srFile ++ " is corrupt, " ++ key ++ " " ++ msg ++ "." case Map.lookup key srAtoms of Nothing -> corrupt "is missing" Just Atom{..}
src/General/Util.hs view
@@ -123,7 +123,7 @@ parseMode = defaultParseMode{extensions=map EnableExtension es} where es = [ConstraintKinds,EmptyDataDecls,TypeOperators,ExplicitForAll,GADTs,KindSignatures,MultiParamTypeClasses ,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples- ,ParallelArrays,UnicodeSyntax,DataKinds,PolyKinds]+ ,ParallelArrays,UnicodeSyntax,DataKinds,PolyKinds,PatternSynonyms] applyType :: Type a -> [Type a] -> Type a applyType x (t:ts) = applyType (TyApp (ann t) x t) ts@@ -187,12 +187,14 @@ DataFamDecl _ _ hd _ -> f hd ClassDecl _ _ hd _ _ -> f hd TypeSig _ names _ -> names+ PatSynSig _ names _ _ _ _ _ -> names _ -> [] where f x = [fst $ fromDeclHead x] isTypeSig :: Decl a -> Bool isTypeSig TypeSig{} = True+isTypeSig PatSynSig{} = True isTypeSig _ = False @@ -275,7 +277,7 @@ strict act = do res <- try_ act case res of- Left e -> do msg <- showException e; evaluate $ rnf msg; error msg+ Left e -> do msg <- showException e; evaluate $ rnf msg; errorIO msg Right v -> evaluate $ force v data Average a = Average !a {-# UNPACK #-} !Int deriving Show -- a / b@@ -380,13 +382,13 @@ general_util_test :: IO () general_util_test = do testing "General.Util.splitPair" $ do- let a === b = if a == b then putChar '.' else error $ show (a,b)+ let a === b = if a == b then putChar '.' else errorIO $ show (a,b) splitPair ":" "module:foo:bar" === ("module","foo:bar") do x <- try_ $ evaluate $ rnf $ splitPair "-" "module:foo"; isLeft x === True splitPair "-" "module-" === ("module","") testing_ "General.Util.inRanges" $ do quickCheck $ \(x :: Int8) xs -> inRanges xs x == any (`inRange` x) xs testing "General.Util.parseTrailingVersion" $ do- let a === b = if a == b then putChar '.' else error $ show (a,b)+ let a === b = if a == b then putChar '.' else errorIO $ show (a,b) parseTrailingVersion "shake-0.15.2" === ("shake",[0,15,2]) parseTrailingVersion "test-of-stuff1" === ("test-of-stuff1",[])
src/General/Web.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards, DeriveFunctor #-} module General.Web(- Input(..), Output(..), readInput, server+ Input(..),+ Taint, taint, carefulUntaint, escapeUntaint,+ Output(..), readInput, server ) where import Network.Wai.Handler.Warp hiding (Port, Handle)@@ -17,6 +19,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.List.Extra+import Data.Char import Data.String import Data.Tuple.Extra import Data.Monoid@@ -30,13 +33,38 @@ data Input = Input {inputURL :: [String]- ,inputArgs :: [(String, String)]+ ,inputArgs :: [(String, Taint String)] } deriving Show +newtype Taint a = Taint a+ deriving (Functor, Show, Eq)++instance Applicative Taint where+ pure = Taint+ Taint f <*> Taint x = Taint $ f x++instance Monad Taint where+ Taint m >>= k = k m+++taint :: a -> Taint a+taint = Taint++carefulUntaint :: Taint a -> a+carefulUntaint (Taint a) = a++escapeUntaint :: Taint String -> String+escapeUntaint = escapeHTML . carefulUntaint+ readInput :: String -> Input-readInput (breakOn "?" -> (a,b)) = Input (dropWhile null $ splitOn "/" a) $- map (second (unEscapeString . drop1) . breakOn "=") $ splitOn "&" $ drop1 b+readInput (breakOn "?" -> (a,b)) = Input (filter (not . badPath) $ dropWhile null $ splitOn "/" a) $+ filter (not . badArg . fst) $ map (second (Taint . 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+ data Output = OutputText LBS.ByteString | OutputHTML LBS.ByteString@@ -77,7 +105,7 @@ 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]+ [(bstrUnpack a, Taint $ maybe "" bstrUnpack b) | (a,b) <- queryString req] (time,res) <- duration $ try_ $ do s <- act pay; evaluate $ force s res <- either (fmap Left . showException) (return . Right) res logAddEntry log (showSockAddr $ remoteHost req)
src/Input/Cabal.hs view
@@ -13,6 +13,7 @@ import System.FilePath import Control.DeepSeq import Control.Exception+import Control.Exception.Extra import Control.Monad import System.IO.Extra import General.Str@@ -82,7 +83,7 @@ -- important to use BS process reading so it's in Binary format, see #194 (exit, stdout, stderr) <- BS.readProcessWithExitCode "ghc-pkg" ["dump"] mempty when (exit /= ExitSuccess) $- fail $ "Error when reading from ghc-pkg, " ++ show exit ++ "\n" ++ UTF8.toString stderr+ errorIO $ "Error when reading from ghc-pkg, " ++ show exit ++ "\n" ++ UTF8.toString stderr let g (stripPrefix "$topdir" -> Just x) | Just t <- topdir = takeDirectory t ++ x g x = x let fixer p = p{packageLibrary = True, packageDocs = g <$> packageDocs p}
src/Input/Download.hs view
@@ -12,6 +12,7 @@ import General.Util import General.Timing import Control.Monad.Trans.Resource+import Control.Exception.Extra -- | Download all the input files to input/@@ -20,7 +21,7 @@ let file = dir </> "input-" ++ name exists <- doesFileExist file when (not exists && download == Just False) $- error $ "File is not already downloaded and --download=no given, downloading " ++ url ++ " to " ++ file+ errorIO $ "File is not already downloaded and --download=no given, downloading " ++ url ++ " to " ++ file when (not exists || download == Just True) $ timed timing ("Downloading " ++ url) $ do downloadFile insecure (file <.> "part") url
src/Input/Haddock.hs view
@@ -12,6 +12,7 @@ import Control.Monad.Trans.Class import General.Conduit import Control.Monad.Extra+import Control.Exception.Extra import Data.Generics.Uniplate.Data import General.Str @@ -171,7 +172,7 @@ input_haddock_test :: IO () input_haddock_test = testing "Input.Haddock.parseLine" $ do let a === b | fmap (map prettyItem) (parseLine a) == Right [b] = putChar '.'- | otherwise = error $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a)+ | otherwise = errorIO $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a) let test a = a === a test "type FilePath = [Char]" test "data Maybe a"@@ -192,3 +193,4 @@ -- Broken in the last HSE release, fixed in HSE HEAD -- test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)" test "( # ) :: Int"+ test "pattern MyPattern :: ()"