From d43a3b8ff30e3bf0b9772b229e58d2b0fa34f8af Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 17 Mar 2025 15:14:24 -0400 Subject: [PATCH 1/8] Fix empty cipher-suite in `downloadFile` --- hoogle.cabal | 1 + src/Input/Download.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/hoogle.cabal b/hoogle.cabal index 9890961c..93ebc74b 100644 --- a/hoogle.cabal +++ b/hoogle.cabal @@ -83,6 +83,7 @@ library temporary, text >= 2, time >= 1.5, + tls, transformers, uniplate, utf8-string >= 0.3.1, diff --git a/src/Input/Download.hs b/src/Input/Download.hs index 5d40608e..a4a12518 100644 --- a/src/Input/Download.hs +++ b/src/Input/Download.hs @@ -8,6 +8,8 @@ import System.Directory import Data.Conduit.Binary (sinkFile) import Data.Default.Class import qualified Network.HTTP.Conduit as C +import Network.TLS (Supported(..)) +import Network.TLS.Extra.Cipher (ciphersuite_default) import Network.Connection import qualified Data.Conduit as C import General.Util @@ -47,7 +49,7 @@ downloadFile insecure file url = do settingDisableCertificateValidation = insecure, settingDisableSession = False, settingUseServerName = False, - settingClientSupported = def + settingClientSupported = def { supportedCiphers = ciphersuite_default } }) Nothing runResourceT $ do response <- C.http request manager From 00a1a179cd7067dc286b6226646e6b5c63a9c353 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 5 Feb 2025 14:02:52 -0500 Subject: [PATCH 2/8] Rip out Frege support --- misc/Upgrade.hs | 3 --- src/Action/CmdLine.hs | 16 +++++----------- src/Action/Generate.hs | 32 +++++++++++--------------------- src/Hoogle.hs | 2 +- 4 files changed, 17 insertions(+), 36 deletions(-) diff --git a/misc/Upgrade.hs b/misc/Upgrade.hs index b33808dc..df768fdc 100644 --- a/misc/Upgrade.hs +++ b/misc/Upgrade.hs @@ -49,9 +49,6 @@ main = do echo system_ $ "hoogle_datadir=. " ++ exe ++ " generate --database=haskell.hoo +RTS -M900M -T -N2" echo system_ $ "hoogle_datadir=. " ++ exe ++ " test --database=haskell.hoo" - when False $ -- Frege database has disappeared - echo system_ $ "hoogle_datadir=. " ++ exe ++ " generate --database=frege.hoo --frege +RTS -M900M -T -N2" - when False $ do -- DAML now has its own server createDirectoryIfMissing True "daml" echo system_ "curl https://docs.daml.com/hoogle_db/base.txt --output daml/base.txt" diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 3ba18e2e..4df826b3 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -32,7 +32,6 @@ data CmdLine ,count :: Maybe Int ,query :: [String] ,repeat_ :: Int - ,language :: Language ,compare_ :: [String] } | Generate @@ -44,7 +43,6 @@ data CmdLine ,local_ :: [FilePath] ,haddock :: Maybe FilePath ,debug :: Bool - ,language :: Language } | Server {port :: Int @@ -54,7 +52,6 @@ data CmdLine ,local :: Bool ,haddock :: Maybe FilePath ,links :: Bool - ,language :: Language ,scope :: String ,home :: String ,host :: String @@ -68,19 +65,17 @@ data CmdLine {logs :: FilePath ,database :: FilePath ,repeat_ :: Int - ,language :: Language ,scope :: String } | Test { deep :: Bool , disable_network_tests :: Bool , database :: FilePath - , language :: Language } deriving (Data,Typeable,Show) -defaultDatabaseLang :: Language -> IO FilePath -defaultDatabaseLang lang = do +defaultDatabaseLang :: IO FilePath +defaultDatabaseLang = do xdgLocation <- getXdgDirectory XdgData "hoogle" legacyLocation <- getAppUserDataDirectory "hoogle" doesXdgPathExist <- doesPathExist xdgLocation @@ -100,7 +95,7 @@ defaultDatabaseLang lang = do --hPutStrLn stderr $ "Warning: " ++ legacyLocation ++ " is deprecated." -- ++ "Consider moving it to $XDG_DATA_HOME/hoogle (" ++ xdgLocation ++ ")" pure legacyLocation - pure $ dir "default-" ++ lower (show lang) ++ "-" ++ showVersion (trimVersion 3 version) ++ ".hoo" + pure $ dir "default-haskell-" ++ showVersion (trimVersion 3 version) ++ ".hoo" getCmdLine :: [String] -> IO CmdLine getCmdLine args = do @@ -108,7 +103,7 @@ getCmdLine args = do -- fill in the default database args <- if database args /= "" then pure args else do - db <- defaultDatabaseLang $ language args; pure args{database=db} + db <- defaultDatabaseLang; pure args{database=db} -- fix up people using Hoogle 4 instructions args <- case args of @@ -121,7 +116,7 @@ getCmdLine args = do defaultGenerate :: CmdLine -defaultGenerate = generate{language=Haskell} +defaultGenerate = generate cmdLineMode = cmdArgsMode $ modes [search_ &= auto,generate,server,replay,test] @@ -139,7 +134,6 @@ search_ = Search ,count = Nothing &= name "n" &= help "Maximum number of results to return (defaults to 10)" ,query = def &= args &= typ "QUERY" ,repeat_ = 1 &= help "Number of times to repeat (for benchmarking)" - ,language = enum [x &= explicit &= name (lower $ show x) &= help ("Work with " ++ show x) | x <- enumerate] &= groupname "Language" ,compare_ = def &= help "Type signatures to compare against" } &= help "Perform a search" diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs index c9214bcf..3f125c66 100644 --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE MultiWayIf #-} module Action.Generate(actionGenerate) where @@ -154,15 +155,6 @@ readHaskellDirs timing settings dirs = do sets = map setFromDir $ filter (`isPrefixOf` file) dirs setFromDir dir = (strPack "set", strPack $ takeFileName $ dropTrailingPathSeparator dir) -readFregeOnline :: Timing -> Download -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) -readFregeOnline timing download = do - frege <- download "frege-frege.txt" "https://github.com/Frege/try-frege/raw/refs/heads/master/try-frege-web/src/main/webapp/hoogle-frege.txt" - let source = do - src <- liftIO $ bstrReadFile frege - yield (mkPackageName "frege", "http://google.com/", lbstrFromChunks [src]) - pure (Map.empty, Set.singleton $ mkPackageName "frege", source) - - readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellGhcpkg timing settings = do cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings @@ -235,18 +227,16 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio downloadInput timing insecure download' (takeDirectory database) name url settings <- loadSettings - (cbl, want, source) <- case language of - Haskell | Just dir <- haddock -> do - warnFlagIgnored "--haddock" "set" (local_ /= []) "--local" - warnFlagIgnored "--haddock" "set" (isJust download) "--download" - readHaskellHaddock timing settings dir - | [""] <- local_ -> do - warnFlagIgnored "--local" "used as flag (no paths)" (isJust download) "--download" - readHaskellGhcpkg timing settings - | [] <- local_ -> do readHaskellOnline timing settings doDownload - | otherwise -> readHaskellDirs timing settings local_ - Frege | [] <- local_ -> readFregeOnline timing doDownload - | otherwise -> errorIO "No support for local Frege databases" + (cbl, want, source) <- + if | Just dir <- haddock -> do + warnFlagIgnored "--haddock" "set" (local_ /= []) "--local" + warnFlagIgnored "--haddock" "set" (isJust download) "--download" + readHaskellHaddock timing settings dir + | [""] <- local_ -> do + warnFlagIgnored "--local" "used as flag (no paths)" (isJust download) "--download" + readHaskellGhcpkg timing settings + | [] <- local_ -> do readHaskellOnline timing settings doDownload + | otherwise -> readHaskellDirs timing settings local_ (cblErrs, popularity) <- evaluate $ packagePopularity cbl cbl <- evaluate $ Map.map (\p -> p{packageDepends=[]}) cbl -- clear the memory, since the information is no longer used evaluate popularity diff --git a/src/Hoogle.hs b/src/Hoogle.hs index 78b86052..b9b5d0f6 100644 --- a/src/Hoogle.hs +++ b/src/Hoogle.hs @@ -31,7 +31,7 @@ withDatabase file act = storeReadFile file $ act . Database -- | The default location of a database defaultDatabaseLocation :: IO FilePath -defaultDatabaseLocation = defaultDatabaseLang Haskell +defaultDatabaseLocation = defaultDatabaseLang -- | Search a database, given a query string, produces a list of results. searchDatabase :: Database -> String -> [Target] From e9d91bc0865fec17da0b9797e2f39def4b6ed1cc Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 5 Feb 2025 14:38:22 -0500 Subject: [PATCH 3/8] Migrate to optparse-applicative And eliminate partiality in mode handlers. --- hoogle.cabal | 2 +- src/Action/CmdLine.hs | 325 +++++++++++++++++++++++++---------------- src/Action/Generate.hs | 14 +- src/Action/Search.hs | 15 +- src/Action/Server.hs | 8 +- src/Action/Test.hs | 21 ++- src/General/Web.hs | 4 +- src/Hoogle.hs | 12 +- 8 files changed, 244 insertions(+), 157 deletions(-) diff --git a/hoogle.cabal b/hoogle.cabal index 93ebc74b..6b0ca84a 100644 --- a/hoogle.cabal +++ b/hoogle.cabal @@ -54,7 +54,7 @@ library binary, bytestring >= 0.10.2.0, Cabal-syntax >= 3.8, - cmdargs, + optparse-applicative, conduit >= 1.3.0, conduit-extra >= 1.2.3.2, containers >= 0.5, diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 4df826b3..21d37f55 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -1,10 +1,20 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ApplicativeDo #-} module Action.CmdLine( - CmdLine(..), Language(..), + -- * Modes of execution + Mode(..), + SearchOpts(..), + GenerateOpts(..), + ServerOpts(..), + ReplayOpts(..), + TestOpts(..), + -- * Parsing command line getCmdLine, defaultDatabaseLang, - defaultGenerate, + -- * Verbosity + Verbosity, whenLoud, whenNormal ) where @@ -12,67 +22,89 @@ import Data.List.Extra import Data.Version import General.Util import Paths_hoogle (version) -import System.Console.CmdArgs +import Options.Applicative as O import System.Directory import System.Environment import System.FilePath import System.IO +import Control.Monad +import Data.Maybe -data Language = Haskell | Frege deriving (Data,Typeable,Show,Eq,Enum,Bounded) - -data CmdLine - = Search - {color :: Maybe Bool - ,json :: Bool - ,jsonl :: Bool - ,link :: Bool - ,numbers :: Bool - ,info :: Bool - ,database :: FilePath - ,count :: Maybe Int - ,query :: [String] - ,repeat_ :: Int - ,compare_ :: [String] +data Verbosity = VerbosityNormal | VerbosityLoud + deriving (Eq, Ord, Show) + +whenLoud, whenNormal :: Verbosity -> IO () -> IO () +whenLoud v k = when (v >= VerbosityLoud) k +whenNormal v k = when (v >= VerbosityNormal) k + + +data SearchOpts + = SearchOpts + { color :: Maybe Bool + , json :: Bool + , jsonl :: Bool + , link :: Bool + , numbers :: Bool + , info :: Bool + , database :: FilePath + , count :: Maybe Int + , query :: [String] + , repeat_ :: Int + , compare_ :: [String] } - | Generate - {download :: Maybe Bool - ,database :: FilePath - ,insecure :: Bool - ,include :: [String] - ,count :: Maybe Int - ,local_ :: [FilePath] - ,haddock :: Maybe FilePath - ,debug :: Bool + +data GenerateOpts + = GenerateOpts + { download :: Maybe Bool + , database :: FilePath + , insecure :: Bool + , include :: [String] + , count :: Maybe Int + , local_ :: [FilePath] + , haddock :: Maybe FilePath + , debug :: Bool } - | Server - {port :: Int - ,database :: FilePath - ,cdn :: String - ,logs :: FilePath - ,local :: Bool - ,haddock :: Maybe FilePath - ,links :: Bool - ,scope :: String - ,home :: String - ,host :: String - ,https :: Bool - ,cert :: FilePath - ,key :: FilePath - ,datadir :: Maybe FilePath - ,no_security_headers :: Bool + +data ServerOpts + = ServerOpts + { port :: Int + , database :: FilePath + , cdn :: String + , logs :: FilePath + , local :: Bool + , haddock :: Maybe FilePath + , links :: Bool + , scope :: String + , home :: String + , host :: String + , https :: Bool + , cert :: FilePath + , key :: FilePath + , datadir :: Maybe FilePath + , no_security_headers :: Bool } - | Replay - {logs :: FilePath - ,database :: FilePath - ,repeat_ :: Int - ,scope :: String + +data ReplayOpts + = ReplayOpts + { logs :: FilePath + , database :: FilePath + , repeat_ :: Int + , scope :: String } - | Test + +data TestOpts + = TestOpts { deep :: Bool , disable_network_tests :: Bool , database :: FilePath } - deriving (Data,Typeable,Show) + +data Mode + = Search SearchOpts + | Generate GenerateOpts + | Server ServerOpts + | Replay ReplayOpts + | Test TestOpts defaultDatabaseLang :: IO FilePath defaultDatabaseLang = do @@ -97,78 +129,119 @@ defaultDatabaseLang = do pure legacyLocation pure $ dir "default-haskell-" ++ showVersion (trimVersion 3 version) ++ ".hoo" -getCmdLine :: [String] -> IO CmdLine +-- N.B. This is rather awkward but seems to be the pragmatic way to migrate +-- away from cmdargs without changing the user-visible command-line syntax. +fillInDatabase :: FilePath -> Mode -> Mode +fillInDatabase defDb (Search opts) + | "" <- opts.database = Search $ opts { database = defDb } +fillInDatabase defDb (Generate opts) + | "" <- opts.database = Generate $ opts { database = defDb } +fillInDatabase defDb (Server opts) + | "" <- opts.database = Server $ opts { database = defDb } +fillInDatabase defDb (Replay opts) + | "" <- opts.database = Replay $ opts { database = defDb } +fillInDatabase defDb (Test opts) + | "" <- opts.database = Test $ opts { database = defDb } +fillInDatabase _ mode = mode + +getCmdLine :: [String] -> IO (Verbosity, Mode) getCmdLine args = do - args <- withArgs args $ cmdArgsRun cmdLineMode - - -- fill in the default database - args <- if database args /= "" then pure args else do - db <- defaultDatabaseLang; pure args{database=db} - - -- fix up people using Hoogle 4 instructions - args <- case args of - Generate{..} | "all" `elem` include -> do - putStrLn "Warning: 'all' argument is no longer required, and has been ignored." - pure $ args{include = delete "all" include} - _ -> pure args - - pure args - - -defaultGenerate :: CmdLine -defaultGenerate = generate - - -cmdLineMode = cmdArgsMode $ modes [search_ &= auto,generate,server,replay,test] - &= verbosity &= program "hoogle" - &= summary ("Hoogle " ++ showVersion version ++ ", https://hoogle.haskell.org/") - -search_ = Search - {color = def &= name "colour" &= help "Use colored output (requires ANSI terminal)" - ,json = def &= name "json" &= help "Get result as JSON" - ,jsonl = def &= name "jsonl" &= help "Get result as JSONL (JSON Lines)" - ,link = def &= help "Give URL's for each result" - ,numbers = def &= help "Give counter for each result" - ,info = def &= help "Give extended information about the first n results (set n with --count, default is 1)" - ,database = def &= typFile &= help "Name of database to use (use .hoo extension)" - ,count = Nothing &= name "n" &= help "Maximum number of results to return (defaults to 10)" - ,query = def &= args &= typ "QUERY" - ,repeat_ = 1 &= help "Number of times to repeat (for benchmarking)" - ,compare_ = def &= help "Type signatures to compare against" - } &= help "Perform a search" - -generate = Generate - {download = def &= help "Download all files from the web" - ,insecure = def &= help "Allow insecure HTTPS connections" - ,include = def &= args &= typ "PACKAGE" - ,local_ = def &= opt "" &= help "Index local packages and link to local haddock docs" - ,count = Nothing &= name "n" &= help "Maximum number of packages to index (defaults to all)" - ,haddock = def &= help "Use local haddocks" - ,debug = def &= help "Generate debug information" - } &= help "Generate Hoogle databases" - -server = Server - {port = 8080 &= typ "INT" &= help "Port number" - ,cdn = "" &= typ "URL" &= help "URL prefix to use" - ,logs = "" &= opt "log.txt" &= typFile &= help "File to log requests to (defaults to stdout)" - ,local = False &= help "Allow following file:// links, restricts to 127.0.0.1 Set --host explicitely (including to '*' for any host) to override the localhost-only behaviour" - ,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 = "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)" - ,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 - {logs = "log.txt" &= args &= typ "FILE" - } &= help "Replay a log file" - -test = Test - { deep = False &= help "Run extra long tests" - , disable_network_tests = False &= help "Disables the use of network tests" - } &= help "Run the test suite" + (verbosity, mode) <- execParser cmdline + + -- fill in the default database TODO + --args <- if args.database /= "" then pure args else do + defDb <- defaultDatabaseLang + pure (verbosity, fillInDatabase defDb mode) + +cmdline :: ParserInfo (Verbosity, Mode) +cmdline = + O.info ((,) <$> verbosity <*> mode' <**> helper <**> simpleVersioner (showVersion version)) (header name) + where + mode' = mode <|> fmap Search searchOpts + verbosity = flag VerbosityNormal VerbosityLoud (short 'v' <> long "verbose" <> help "emit verbose output") + name = "Hoogle " ++ showVersion version ++ ", https://hoogle.haskell.org/" + +mode :: Parser Mode +mode = hsubparser + $ command "search" (O.info (Search <$> searchOpts) (progDesc "Perform a search")) + <> command "generate" (O.info (Generate <$> generateOpts) (progDesc "Generate Hoogle databases")) + <> command "serve" (O.info (Server <$> serverOpts) (progDesc "Start a Hoogle server")) + <> command "replay" (O.info (Replay <$> replayOpts) (progDesc "Replay a log file")) + <> command "test" (O.info (Test <$> testOpts) (progDesc "Run the test suite")) + +databaseFlag :: Parser FilePath +databaseFlag = + option str (long "database" <> short 'd' <> metavar "FILE" <> help "Name of database to use (use .hoo extension)") + +logsFlag :: Parser FilePath +logsFlag = + option (fromMaybe "log.txt" <$> optional str) (value "" <> metavar "FILE" <> help "File to log requests to (defaults to stdout)") + +repeatFlag :: Parser Int +repeatFlag = + option auto (long "repeat" <> short 'r' <> value 1 <> help "Number of times to repeat (for benchmarking)") + +scopeFlag :: Parser String +scopeFlag = + option str (long "scope" <> short 's' <> help "Default scope to start with") + +searchOpts :: Parser SearchOpts +searchOpts = do + color <- optional $ switch (long "colour" <> help "Use colored output (requires ANSI terminal)") + json <- switch (long "json" <> help "Get result as JSON") + jsonl <- switch (long "jsonl" <> help "Get result as JSONL (JSON Lines)") + link <- switch (long "link" <> help "Give URL's for each result") + numbers <- switch (long "numbers" <> help "Give counter for each result") + info <- switch (long "info" <> help "Give extended information about the first n results (set n with --count, default is 1)") + database <- databaseFlag + count <- optional $ option auto (short 'n' <> long "count" <> help "Maximum number of results to return (defaults to 10)") + query <- some $ argument str (metavar "QUERY") + repeat_ <- repeatFlag + compare_ <- many $ option str (long "compare" <> metavar "SIG" <> help "Type signatures to compare against") + pure $ SearchOpts {..} + +generateOpts :: Parser GenerateOpts +generateOpts = do + download <- optional $ switch (long "download" <> help "Download all files from the web") + database <- databaseFlag + insecure <- switch (long "insecure" <> short 'i' <> help "Allow insecure HTTPS connections") + include <- many $ argument str (metavar "PACKAGE" <> help "Packages to include") + local_ <- many $ option (fromMaybe "" <$> optional str) (long "local" <> short 'l' <> help "Index local packages and link to local haddock docs") + count <- optional $ option auto (long "count" <> short 'n' <> help "Maximum number of packages to index (defaults to all)") + haddock <- optional $ option str (long "haddock" <> short 'h' <> help "Use local haddocks") + debug <- switch (long "debug" <> help "Generate debug information") + pure $ GenerateOpts {..} + +serverOpts :: Parser ServerOpts +serverOpts = do + port <- option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number") + database <- databaseFlag + cdn <- option str (value "" <> metavar "URL" <> help "URL prefix to use") + logs <- logsFlag + local <- switch (long "local" <> help "Allow following file:// links, restricts to 127.0.0.1 Set --host explicitely (including to '*' for any host) to override the localhost-only behaviour") + haddock <- optional $ option str (long "haddock" <> metavar "DIR" <> help "Serve local haddocks from a specified directory") + scope <- scopeFlag + links <- switch (long "links" <> help "Display extra links") + home <- option str (long "home" <> value "https://hoogle.haskell.org" <> metavar "URL" <> help "Set the URL linked to by the Hoogle logo.") + host <- option str (long "host" <> value "" <> 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 <- switch (long "https" <> help "Start an https server (use --cert and --key to specify paths to the .pem files)") + cert <- option str (value "cert.pem" <> metavar "FILE" <> help "Path to the certificate pem file (when running an https server)") + key <- option str (long "key" <> short 'k' <> value "key.pem" <> metavar "FILE" <> help "Path to the key pem file (when running an https server)") + datadir <- optional $ option str (long "datadir" <> metavar "DIR" <> help "Override data directory path") + no_security_headers <- switch (long "no-security-headers" <> short 'n' <> help "Don't send CSP security headers") + pure ServerOpts {..} + +replayOpts :: Parser ReplayOpts +replayOpts = do + logs <- logsFlag + database <- databaseFlag + repeat_ <- repeatFlag + scope <- scopeFlag + pure ReplayOpts {..} + +testOpts :: Parser TestOpts +testOpts = do + deep <- switch (long "deep" <> help "Run extra long tests") + database <- databaseFlag + disable_network_tests <- switch (long "disable-network-tests" <> help "Disables the use of network tests") + pure TestOpts {..} diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs index 3f125c66..30e15b03 100644 --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -16,7 +16,6 @@ import qualified Data.Map.Strict as Map import Control.Monad.Extra import Data.Monoid import Data.Ord -import System.Console.CmdArgs.Verbosity import Prelude import Output.Items @@ -210,11 +209,11 @@ readHaskellHaddock timing settings docBaseDir = do where docDir name Package{..} = name ++ "-" ++ strUnpack packageVersion -actionGenerate :: CmdLine -> IO () -actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtension database "timing" else Nothing) $ \timing -> do +actionGenerate :: Verbosity -> GenerateOpts -> IO () +actionGenerate verbosity g@GenerateOpts{..} = withTiming (if debug then Just $ replaceExtension database "timing" else Nothing) $ \timing -> do putStrLn "Starting generate" createDirectoryIfMissing True $ takeDirectory database - whenLoud $ putStrLn $ "Generating files to " ++ takeDirectory database + whenLoud verbosity $ putStrLn $ "Generating files to " ++ takeDirectory database let warnFlagIgnored thisFlag reason ignoredFlagPred ignoredFlag = when ignoredFlagPred $ putStrLn $ "Warning: " <> thisFlag <> " is " <> reason <> ", which means " <> ignoredFlag <> " is ignored." @@ -268,7 +267,7 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio let missing = [x | x <- Set.toList $ want `Set.difference` seen , fmap packageLibrary (Map.lookup x cbl) /= Just False] liftIO $ putStrLn "" - liftIO $ whenNormal $ when (missing /= []) $ do + liftIO $ whenNormal verbosity $ when (missing /= []) $ do putStrLn $ "Packages missing documentation: " ++ unwords (sortOn lower $ map unPackageName missing) liftIO $ when (Set.null seen) $ exitFail "No packages were found, aborting (use no arguments to index all of Stackage)" @@ -297,10 +296,9 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio timed timing "Writing names" $ writeNames store xs timed timing "Writing types" $ writeTypes store (if debug then Just $ dropExtension database else Nothing) xs - x <- getVerbosity - when (x >= Loud) $ + whenLoud verbosity $ whenJustM getStatsDebug print - when (x >= Normal) $ do + whenNormal verbosity $ do whenJustM getStatsPeakAllocBytes $ \x -> putStrLn $ "Peak of " ++ x ++ ", " ++ fromMaybe "unknown" itemsMemory ++ " for items" diff --git a/src/Action/Search.hs b/src/Action/Search.hs index b86ed552..6dfbf9d1 100644 --- a/src/Action/Search.hs +++ b/src/Action/Search.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE LambdaCase, MultiWayIf, RecordWildCards, ScopedTypeVariables, - TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Action.Search (actionSearch, withSearch, search @@ -42,13 +45,13 @@ import Query -- @tagsoup filter -- search the tagsoup package -- filter -- search all -actionSearch :: CmdLine -> IO () -actionSearch Search{..} = replicateM_ repeat_ $ -- deliberately reopen the database each time +actionSearch :: Verbosity -> SearchOpts -> IO () +actionSearch verbosity SearchOpts{..} = replicateM_ repeat_ $ -- deliberately reopen the database each time withSearch database $ \store -> if null compare_ then do count' <- pure $ fromMaybe 10 count (q, res) <- pure $ search store $ parseQuery $ unwords query - whenLoud $ putStrLn $ "Query: " ++ unescapeHTML (LBS.unpack $ renderMarkup $ renderQuery q) + whenLoud verbosity $ putStrLn $ "Query: " ++ unescapeHTML (LBS.unpack $ renderMarkup $ renderQuery q) color' <- case color of Just b -> pure b Nothing -> hSupportsANSI stdout @@ -65,7 +68,7 @@ actionSearch Search{..} = replicateM_ repeat_ $ -- deliberately reopen the datab | jsonl -> mapM_ (LBS.putStrLn . JSON.encode) $ maybe id take count $ map unHTMLtargetItem res | otherwise -> putStr $ unlines $ if numbers then addCounter shown else shown when (hidden /= [] && not json) $ do - whenNormal $ putStrLn $ "-- plus more results not shown, pass --count=" ++ show (count'+10) ++ " to see more" + whenNormal verbosity $ putStrLn $ "-- plus more results not shown, pass --count=" ++ show (count'+10) ++ " to see more" else do let parseType x = case parseQuery x of [QueryType t] -> (pretty t, hseToSig t) diff --git a/src/Action/Server.hs b/src/Action/Server.hs index 0f080bad..cc5b8e76 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -49,8 +49,8 @@ import Prelude import qualified Data.Aeson as JSON -actionServer :: CmdLine -> IO () -actionServer cmd@Server{..} = do +actionServer :: Verbosity -> ServerOpts -> IO () +actionServer verbosity cmd@ServerOpts{..} = do -- so I can get good error messages hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -66,8 +66,8 @@ actionServer cmd@Server{..} = do withSearch database $ \store -> server log cmd $ replyServer log local links haddock store cdn home (dataDir "html") scope -actionReplay :: CmdLine -> IO () -actionReplay Replay{..} = withBuffering stdout NoBuffering $ do +actionReplay :: Verbosity -> ReplayOpts -> IO () +actionReplay verbosity ReplayOpts{..} = withBuffering stdout NoBuffering $ do src <- readFile logs let qs = catMaybes [readInput url | _:ip:_:url:_ <- map words $ lines src, ip /= "-"] (t,_) <- duration $ withSearch database $ \store -> do diff --git a/src/Action/Test.hs b/src/Action/Test.hs index 2c86ef33..a5433c3b 100644 --- a/src/Action/Test.hs +++ b/src/Action/Test.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE TupleSections, RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} module Action.Test(actionTest) where @@ -19,8 +22,8 @@ import Control.DeepSeq import Control.Exception -actionTest :: CmdLine -> IO () -actionTest Test{..} = withBuffering stdout NoBuffering $ withTempFile $ \sample -> do +actionTest :: Verbosity -> TestOpts -> IO () +actionTest verbosity TestOpts{..} = withBuffering stdout NoBuffering $ withTempFile $ \sample -> do putStrLn "Code tests" general_util_test general_web_test @@ -31,7 +34,17 @@ actionTest Test{..} = withBuffering stdout NoBuffering $ withTempFile $ \sample putStrLn "" putStrLn "Sample database tests" - actionGenerate defaultGenerate{database=sample, local_=["misc/sample-data"]} + let generateOpts = + GenerateOpts { database = sample + , local_ = ["misc/sample-data"] + , download = Nothing + , insecure = False + , include = [] + , count = Nothing + , haddock = Nothing + , debug = False + } + actionGenerate verbosity generateOpts action_search_test True sample unless disable_network_tests $ action_server_test True sample putStrLn "" diff --git a/src/General/Web.hs b/src/General/Web.hs index a438d4ee..204df2e5 100644 --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -81,8 +81,8 @@ forceBS (OutputFile x) = rnf x `seq` LBS.empty instance NFData Output where rnf x = forceBS x `seq` () -server :: Log -> CmdLine -> (Input -> IO Output) -> IO () -server log Server{..} act = do +server :: Log -> ServerOpts -> (Input -> IO Output) -> IO () +server log ServerOpts{..} act = do let host' = fromString $ if host == "" then diff --git a/src/Hoogle.hs b/src/Hoogle.hs index b9b5d0f6..bf3b1d8b 100644 --- a/src/Hoogle.hs +++ b/src/Hoogle.hs @@ -41,10 +41,10 @@ searchDatabase (Database db) query = snd $ search db $ parseQuery query -- | Run a command line Hoogle operation. hoogle :: [String] -> IO () hoogle args = do - args <- getCmdLine args + (verbosity, args) <- getCmdLine args case args of - Search{} -> actionSearch args - Generate{} -> actionGenerate args - Server{} -> actionServer args - Test{} -> actionTest args - Replay{} -> actionReplay args + Search opts -> actionSearch verbosity opts + Generate opts -> actionGenerate verbosity opts + Server opts -> actionServer verbosity opts + Test opts -> actionTest verbosity opts + Replay opts -> actionReplay verbosity opts From a3e443fe87bdd800cee6b7e100c2d510ed6716bf Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 5 Feb 2025 15:43:05 -0500 Subject: [PATCH 4/8] Allow serving over UNIX domain socket --- hoogle.cabal | 2 ++ src/Action/CmdLine.hs | 28 ++++++++++++++++++---- src/Action/Server.hs | 2 +- src/General/Web.hs | 55 +++++++++++++++++++++++++++---------------- 4 files changed, 62 insertions(+), 25 deletions(-) diff --git a/hoogle.cabal b/hoogle.cabal index 6b0ca84a..fbdb0852 100644 --- a/hoogle.cabal +++ b/hoogle.cabal @@ -74,6 +74,7 @@ library js-flot, js-jquery, mmap, + network, process-extras, resourcet, safe >= 0.3.20, @@ -85,6 +86,7 @@ library time >= 1.5, tls, transformers, + streaming-commons, uniplate, utf8-string >= 0.3.1, vector, diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 21d37f55..797928e5 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -11,6 +11,9 @@ module Action.CmdLine( ServerOpts(..), ReplayOpts(..), TestOpts(..), + -- * Endpoints + ServerEndpoint(..), + showEndpoint, -- * Parsing command line getCmdLine, defaultDatabaseLang, -- * Verbosity @@ -67,7 +70,7 @@ data GenerateOpts data ServerOpts = ServerOpts - { port :: Int + { endpoint :: ServerEndpoint , database :: FilePath , cdn :: String , logs :: FilePath @@ -76,7 +79,6 @@ data ServerOpts , links :: Bool , scope :: String , home :: String - , host :: String , https :: Bool , cert :: FilePath , key :: FilePath @@ -106,6 +108,14 @@ data Mode | Replay ReplayOpts | Test TestOpts +data ServerEndpoint + = UnixSocket FilePath + | TcpSocket String Int + +showEndpoint :: ServerEndpoint -> String +showEndpoint (TcpSocket host port) = "port " <> show port <> " on host " <> host +showEndpoint (UnixSocket sock) = "socket " <> sock + defaultDatabaseLang :: IO FilePath defaultDatabaseLang = do xdgLocation <- getXdgDirectory XdgData "hoogle" @@ -212,9 +222,20 @@ generateOpts = do debug <- switch (long "debug" <> help "Generate debug information") pure $ GenerateOpts {..} +unixEndpoint :: Parser ServerEndpoint +unixEndpoint = + UnixSocket <$> option str (long "socket" <> metavar "PATH" <> help "UNIX socket") + +tcpEndpoint :: Parser ServerEndpoint +tcpEndpoint = + TcpSocket <$> host <*> port + where + host = option str (long "host" <> value "*" <> help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host).") + port = option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number") + serverOpts :: Parser ServerOpts serverOpts = do - port <- option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number") + endpoint <- unixEndpoint <|> tcpEndpoint database <- databaseFlag cdn <- option str (value "" <> metavar "URL" <> help "URL prefix to use") logs <- logsFlag @@ -223,7 +244,6 @@ serverOpts = do scope <- scopeFlag links <- switch (long "links" <> help "Display extra links") home <- option str (long "home" <> value "https://hoogle.haskell.org" <> metavar "URL" <> help "Set the URL linked to by the Hoogle logo.") - host <- option str (long "host" <> value "" <> 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 <- switch (long "https" <> help "Start an https server (use --cert and --key to specify paths to the .pem files)") cert <- option str (value "cert.pem" <> metavar "FILE" <> help "Path to the certificate pem file (when running an https server)") key <- option str (long "key" <> short 'k' <> value "key.pem" <> metavar "FILE" <> help "Path to the key pem file (when running an https server)") diff --git a/src/Action/Server.hs b/src/Action/Server.hs index cc5b8e76..66fcfbe7 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -54,7 +54,7 @@ actionServer verbosity cmd@ServerOpts{..} = do -- so I can get good error messages hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - putStrLn $ "Server started on port " ++ show port + putStrLn $ "Server started on " ++ showEndpoint endpoint putStr "Reading log..." >> hFlush stdout time <- offsetTime log <- logCreate (if logs == "" then Left stdout else Right logs) $ diff --git a/src/General/Web.hs b/src/General/Web.hs index 204df2e5..4e898c9d 100644 --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards, DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} module General.Web( Input(..), Output(..), readInput, server, general_web_test ) where +import Data.Streaming.Network (bindPath, bindPortTCP) import Network.Wai.Handler.Warp hiding (Port, Handle) import Network.Wai.Handler.WarpTLS @@ -12,6 +14,7 @@ import Action.CmdLine import Network.Wai.Logger import Network.Wai import Control.DeepSeq +import Network.Socket (Socket, close) import Network.HTTP.Types (parseQuery, decodePathSegments) import Network.HTTP.Types.Status import qualified Data.Text as Text @@ -81,25 +84,37 @@ forceBS (OutputFile x) = rnf x `seq` LBS.empty instance NFData Output where rnf x = forceBS x `seq` () +runServer + :: ServerOpts + -> Application + -> IO () +runServer opts app = + withEndpointSocket (local opts) (endpoint opts) $ \sock -> + if https opts + then runTLSSocket (tlsSettings (cert opts) (key opts)) settings sock app + else runSettingsSocket settings sock app + where + settings = setOnExceptionResponse exceptionResponseForDebug defaultSettings + +withEndpointSocket + :: Bool -- ^ local + -> ServerEndpoint + -> (Socket -> IO a) + -> IO a +withEndpointSocket _ (UnixSocket sock) = + bracket (bindPath sock) close +withEndpointSocket local (TcpSocket host port) = + bracket (bindPortTCP port host') close + where + host' = fromString $ + if | "" <- host + , local -> "127.0.0.1" + | "" <- host -> "*" + | otherwise -> host + server :: Log -> ServerOpts -> (Input -> IO Output) -> IO () -server log ServerOpts{..} act = do - let - host' = fromString $ - if host == "" then - if local then - "127.0.0.1" - else - "*" - else - host - set = setOnExceptionResponse exceptionResponseForDebug - . setHost host' - . setPort port $ - defaultSettings - runServer :: Application -> IO () - runServer = if https then runTLS (tlsSettings cert key) set - else runSettings set - secH = if no_security_headers then [] +server log opts@ServerOpts{..} act = do + let secH = if no_security_headers then [] else [ -- The CSP is giving additional instructions to the browser. ("Content-Security-Policy", @@ -163,9 +178,9 @@ server log ServerOpts{..} act = do -- call happens. ("Strict-Transport-Security", "max-age=31536000; includeSubDomains")] - logAddMessage log $ "Server starting on port " ++ show port ++ " and host/IP " ++ show host' + logAddMessage log $ "Server starting on " <> showEndpoint endpoint - runServer $ \req reply -> do + runServer opts $ \req reply -> do let pq = BS.unpack $ rawPathInfo req <> rawQueryString req putStrLn pq (time, res) <- duration $ case readInput pq of From 63e5ce31ae1c8c82178ca7c901e5b1fd33a4912a Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 5 Feb 2025 12:14:53 -0500 Subject: [PATCH 5/8] Add flake for haskell.org deployment --- deploy.nix | 112 +++++++++++++++++++++++++++++++++++++++++++++++++++++ flake.lock | 60 ++++++++++++++++++++++++++++ flake.nix | 55 ++++++++++++++++++++++++++ 3 files changed, 227 insertions(+) create mode 100644 deploy.nix create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/deploy.nix b/deploy.nix new file mode 100644 index 00000000..d5584e57 --- /dev/null +++ b/deploy.nix @@ -0,0 +1,112 @@ +{ hoogle, cores ? 4 }: +{ config, pkgs, ... }: + +# The Plan: +# Hoogle serves on a uniquely-named UNIX domain socket which we +# configure nginx to forward to via the nginxConf configuration +# fragment. The Hoogle database is periodically updated by +# rotate-hoogle.service which generates a new Hoogle database, +# starts a new hoogle server, updates the nginx configuration +# and shuts down the old server. + +let + hoogleRun = "/run/hoogle"; + nginxConf = "${hoogleRun}/nginx.conf"; + socket = "/run/hoogle/hoogle.sock"; +in +{ + users.users.hoogle = { + isSystemUser = true; + description = "hoogle server"; + group = "hoogle"; + }; + + users.groups.hoogle = { + members = [ "nginx" ]; + }; + + systemd.timers."generate-hoogle" = { + description = "Rotate Hoogle instance"; + timerConfig = { + Unit = "generate-hoogle.service"; + OnCalendar = "hourly"; + Persistent = true; + }; + wantedBy = [ "timers.target" ]; + }; + + systemd.services."generate-hoogle" = { + script = '' + hoogle generate --database=$DB_DIR/haskell-new.hoo --insecure --download +RTS -N${toString cores} -RTS + mv $DB_DIR/haskell-new.hoo $DB_DIR/haskell.hoo + ''; + path = [ hoogle ]; + after = [ "network.target" ]; + serviceConfig = { + User = "hoogle"; + Group = "hoogle"; + Type = "oneshot"; + TimeoutStartSec = 600; + ExecStartPost = "+systemctl restart hoogle.service"; + BindReadOnlyPaths = [ + # mount the nix store read-only + "/nix/store" + # getAppUserDataDirectory needs getUserEntryForID + "/etc/passwd" + ]; + PrivateNetwork = false; + RuntimeDirectory = "generate-hoogle"; + StateDirectory = [ "hoogle" ]; + }; + environment = { + DB_DIR = "%S/hoogle"; + }; + }; + + systemd.services."hoogle" = { + script = '' + hoogle serve \ + --database=$DB_DIR/haskell.hoo \ + --scope=set:stackage \ + --socket=${socket} \ + --links \ + +RTS -T -N${toString cores} -RTS; + ''; + path = [ hoogle ]; + serviceConfig = { + User = "nginx"; + Group = "hoogle"; + BindReadOnlyPaths = [ + # mount the nix store read-only + "/nix/store" + # getAppUserDataDirectory needs getUserEntryForID + "/etc/passwd" + #"/etc/ssl" "/etc/ssl/certs" + ]; + PrivateTmp = false; + ProtectSystem = false; + ProtectHome = false; + NoNewPrivileges = false; + Restart = "on-failure"; + RestartSec = "5s"; + RuntimeDirectory = "hoogle"; + }; + environment = { + DB_DIR = "%S/hoogle"; + SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; + NIX_SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; + }; + wantedBy = [ "multi-user.target" ]; + }; + + systemd.tmpfiles.rules = [ + "f ${nginxConf} 0755 nginx nginx -" + ]; + + services.nginx = { + upstreams.hoogle.extraConfig = '' + server unix:${socket}; + ''; + }; +} + diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..bae7c7ed --- /dev/null +++ b/flake.lock @@ -0,0 +1,60 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1738774914, + "narHash": "sha256-4PdqiqwNjd+JHC1o7a9CBASKARTl+FqVH0SW3bcGNAY=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "66555b199d5b2620d122ab9330205abdb1abb7bd", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..a9dc07de --- /dev/null +++ b/flake.nix @@ -0,0 +1,55 @@ +{ + description = "haskell.org hoogle deployment"; + + inputs.nixpkgs.url = "github:nixos/nixpkgs"; + inputs.flake-utils.url = "github:numtide/flake-utils"; + + outputs = { self, nixpkgs, flake-utils }: + flake-utils.lib.eachDefaultSystem (system: + let pkgs = nixpkgs.legacyPackages.${system}; in + { + packages = rec { + hoogle = + let + hsPkgs = pkgs.haskellPackages.override { + overrides = self: super: { + crypton-connection = super.crypton-connection_0_4_3; + }; + }; + in hsPkgs.callCabal2nix "hoogle" ./. { }; + default = hoogle; + }; + apps = rec { + hoogle = flake-utils.lib.mkApp { drv = self.packages.${system}.hoogle; }; + default = hoogle; + }; + }) // { + nixosConfigurations."hoogle-test" = nixpkgs.lib.nixosSystem { + system = "x86_64-linux"; + modules = [ + { boot.isContainer = true; } + (import ./deploy.nix { + hoogle = self.packages.x86_64-linux.hoogle; + cores = 4; + }) + { + services.nginx.virtualHosts."hoogle.haskell.org" = { + locations."/" = { + proxyPass = "http://hoogle"; + }; + addSSL = true; + }; + } + ]; + }; + + nixosModules.hoogle-haskell-org = { pkgs, ... }: { + imports = [ + (import ./deploy.nix { + hoogle = self.packages.${pkgs.stdenv.hostPlatform.system}.hoogle; + cores = 4; + }) + ]; + }; + }; +} From 949352161197dd41ba5609b2752e1deb88ef1e18 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 9 Apr 2025 15:46:21 -0400 Subject: [PATCH 6/8] deploy: Support multiple backends --- deploy.nix | 143 ++++++++++++++++++++++++++++------------------------- 1 file changed, 76 insertions(+), 67 deletions(-) diff --git a/deploy.nix b/deploy.nix index d5584e57..1d2b4961 100644 --- a/deploy.nix +++ b/deploy.nix @@ -1,5 +1,5 @@ { hoogle, cores ? 4 }: -{ config, pkgs, ... }: +{ config, lib, pkgs, ... }: # The Plan: # Hoogle serves on a uniquely-named UNIX domain socket which we @@ -12,7 +12,8 @@ let hoogleRun = "/run/hoogle"; nginxConf = "${hoogleRun}/nginx.conf"; - socket = "/run/hoogle/hoogle.sock"; + socket = inst: "/run/hoogle/hoogle-${inst}.sock"; + nServers = 12; in { users.users.hoogle = { @@ -35,78 +36,86 @@ in wantedBy = [ "timers.target" ]; }; - systemd.services."generate-hoogle" = { - script = '' - hoogle generate --database=$DB_DIR/haskell-new.hoo --insecure --download +RTS -N${toString cores} -RTS - mv $DB_DIR/haskell-new.hoo $DB_DIR/haskell.hoo - ''; - path = [ hoogle ]; - after = [ "network.target" ]; - serviceConfig = { - User = "hoogle"; - Group = "hoogle"; - Type = "oneshot"; - TimeoutStartSec = 600; - ExecStartPost = "+systemctl restart hoogle.service"; - BindReadOnlyPaths = [ - # mount the nix store read-only - "/nix/store" - # getAppUserDataDirectory needs getUserEntryForID - "/etc/passwd" - ]; - PrivateNetwork = false; - RuntimeDirectory = "generate-hoogle"; - StateDirectory = [ "hoogle" ]; + systemd.services = { + "generate-hoogle" = { + script = '' + hoogle generate --database=$DB_DIR/haskell-new.hoo --insecure --download +RTS -N${toString cores} -RTS + mv $DB_DIR/haskell-new.hoo $DB_DIR/haskell.hoo + ''; + path = [ hoogle ]; + after = [ "network.target" ]; + serviceConfig = { + User = "hoogle"; + Group = "hoogle"; + Type = "oneshot"; + TimeoutStartSec = 600; + ExecStartPost = "+systemctl restart 'hoogle@*'"; + BindReadOnlyPaths = [ + # mount the nix store read-only + "/nix/store" + # getAppUserDataDirectory needs getUserEntryForID + "/etc/passwd" + ]; + PrivateNetwork = false; + RuntimeDirectory = "generate-hoogle"; + StateDirectory = [ "hoogle" ]; + }; + environment = { + DB_DIR = "%S/hoogle"; + }; }; - environment = { - DB_DIR = "%S/hoogle"; - }; - }; - systemd.services."hoogle" = { - script = '' - hoogle serve \ - --database=$DB_DIR/haskell.hoo \ - --scope=set:stackage \ - --socket=${socket} \ - --links \ - +RTS -T -N${toString cores} -RTS; - ''; - path = [ hoogle ]; - serviceConfig = { - User = "nginx"; - Group = "hoogle"; - BindReadOnlyPaths = [ - # mount the nix store read-only - "/nix/store" - # getAppUserDataDirectory needs getUserEntryForID - "/etc/passwd" - #"/etc/ssl" "/etc/ssl/certs" - ]; - PrivateTmp = false; - ProtectSystem = false; - ProtectHome = false; - NoNewPrivileges = false; - Restart = "on-failure"; - RestartSec = "5s"; - RuntimeDirectory = "hoogle"; - }; - environment = { - DB_DIR = "%S/hoogle"; - SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; - NIX_SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; + "hoogle@" = { + script = '' + ${hoogle}/bin/hoogle serve \ + --database=$DB_DIR/haskell.hoo \ + --scope=set:stackage \ + --socket=$SOCKET \ + --links \ + +RTS -T -RTS; + ''; + serviceConfig = { + User = "nginx"; + Group = "hoogle"; + BindReadOnlyPaths = [ + # mount the nix store read-only + "/nix/store" + # getAppUserDataDirectory needs getUserEntryForID + "/etc/passwd" + #"/etc/ssl" "/etc/ssl/certs" + ]; + PrivateTmp = false; + ProtectSystem = false; + ProtectHome = false; + NoNewPrivileges = false; + Restart = "on-failure"; + RestartSec = "5s"; + RuntimeDirectory = "hoogle"; + }; + environment = { + DB_DIR = "%S/hoogle"; + SOCKET = socket "%i"; + SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; + NIX_SSL_CERT_FILE = "${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt"; + }; }; - wantedBy = [ "multi-user.target" ]; - }; + } // ( + let + mkInst = n: + lib.attrsets.nameValuePair "hoogle@${toString n}" + { + wantedBy = [ "multi-user.target" ]; + overrideStrategy = "asDropin"; + }; + in lib.listToAttrs (map mkInst (lib.range 1 nServers)) + ); systemd.tmpfiles.rules = [ "f ${nginxConf} 0755 nginx nginx -" ]; - services.nginx = { - upstreams.hoogle.extraConfig = '' - server unix:${socket}; - ''; - }; + services.nginx.upstreams.hoogle.servers = + let mkInst = n: lib.attrsets.nameValuePair "unix:${socket (toString n)}" { }; + in lib.listToAttrs (map mkInst (lib.range 1 nServers)); } From e5d40ad48e8b175007f3addeb736cbbcc7eae3f2 Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Mon, 26 Jan 2026 23:28:01 +0000 Subject: [PATCH 7/8] Rework parsing of database flag: make it properly optional --- src/Action/CmdLine.hs | 82 ++++++++++++++++--------------------------- 1 file changed, 30 insertions(+), 52 deletions(-) diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 797928e5..020d0ecb 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE ApplicativeDo #-} module Action.CmdLine( @@ -21,13 +20,11 @@ module Action.CmdLine( whenLoud, whenNormal ) where -import Data.List.Extra import Data.Version import General.Util import Paths_hoogle (version) import Options.Applicative as O import System.Directory -import System.Environment import System.FilePath import System.IO import Control.Monad @@ -40,7 +37,6 @@ whenLoud, whenNormal :: Verbosity -> IO () -> IO () whenLoud v k = when (v >= VerbosityLoud) k whenNormal v k = when (v >= VerbosityNormal) k - data SearchOpts = SearchOpts { color :: Maybe Bool @@ -139,49 +135,31 @@ defaultDatabaseLang = do pure legacyLocation pure $ dir "default-haskell-" ++ showVersion (trimVersion 3 version) ++ ".hoo" --- N.B. This is rather awkward but seems to be the pragmatic way to migrate --- away from cmdargs without changing the user-visible command-line syntax. -fillInDatabase :: FilePath -> Mode -> Mode -fillInDatabase defDb (Search opts) - | "" <- opts.database = Search $ opts { database = defDb } -fillInDatabase defDb (Generate opts) - | "" <- opts.database = Generate $ opts { database = defDb } -fillInDatabase defDb (Server opts) - | "" <- opts.database = Server $ opts { database = defDb } -fillInDatabase defDb (Replay opts) - | "" <- opts.database = Replay $ opts { database = defDb } -fillInDatabase defDb (Test opts) - | "" <- opts.database = Test $ opts { database = defDb } -fillInDatabase _ mode = mode - getCmdLine :: [String] -> IO (Verbosity, Mode) getCmdLine args = do - (verbosity, mode) <- execParser cmdline - - -- fill in the default database TODO - --args <- if args.database /= "" then pure args else do defDb <- defaultDatabaseLang - pure (verbosity, fillInDatabase defDb mode) + (verbosity, mode) <- execParser (cmdline defDb) + pure (verbosity, mode) -cmdline :: ParserInfo (Verbosity, Mode) -cmdline = +cmdline :: FilePath -> ParserInfo (Verbosity, Mode) +cmdline defDb = O.info ((,) <$> verbosity <*> mode' <**> helper <**> simpleVersioner (showVersion version)) (header name) where - mode' = mode <|> fmap Search searchOpts + mode' = mode defDb <|> fmap Search (searchOpts defDb) verbosity = flag VerbosityNormal VerbosityLoud (short 'v' <> long "verbose" <> help "emit verbose output") name = "Hoogle " ++ showVersion version ++ ", https://hoogle.haskell.org/" -mode :: Parser Mode -mode = hsubparser - $ command "search" (O.info (Search <$> searchOpts) (progDesc "Perform a search")) - <> command "generate" (O.info (Generate <$> generateOpts) (progDesc "Generate Hoogle databases")) - <> command "serve" (O.info (Server <$> serverOpts) (progDesc "Start a Hoogle server")) - <> command "replay" (O.info (Replay <$> replayOpts) (progDesc "Replay a log file")) - <> command "test" (O.info (Test <$> testOpts) (progDesc "Run the test suite")) +mode :: FilePath -> Parser Mode +mode defDb = hsubparser + $ command "search" (O.info (Search <$> searchOpts defDb) (progDesc "Perform a search")) + <> command "generate" (O.info (Generate <$> generateOpts defDb) (progDesc "Generate Hoogle databases")) + <> command "serve" (O.info (Server <$> serverOpts defDb) (progDesc "Start a Hoogle server")) + <> command "replay" (O.info (Replay <$> replayOpts defDb) (progDesc "Replay a log file")) + <> command "test" (O.info (Test <$> testOpts defDb) (progDesc "Run the test suite")) -databaseFlag :: Parser FilePath -databaseFlag = - option str (long "database" <> short 'd' <> metavar "FILE" <> help "Name of database to use (use .hoo extension)") +databaseFlag :: FilePath -> Parser FilePath +databaseFlag defDb = + option str (long "database" <> short 'd' <> metavar "FILE" <> help "Name of database to use (use .hoo extension)" <> value defDb <> showDefault) logsFlag :: Parser FilePath logsFlag = @@ -195,25 +173,25 @@ scopeFlag :: Parser String scopeFlag = option str (long "scope" <> short 's' <> help "Default scope to start with") -searchOpts :: Parser SearchOpts -searchOpts = do +searchOpts :: FilePath -> Parser SearchOpts +searchOpts defDb = do color <- optional $ switch (long "colour" <> help "Use colored output (requires ANSI terminal)") json <- switch (long "json" <> help "Get result as JSON") jsonl <- switch (long "jsonl" <> help "Get result as JSONL (JSON Lines)") link <- switch (long "link" <> help "Give URL's for each result") numbers <- switch (long "numbers" <> help "Give counter for each result") info <- switch (long "info" <> help "Give extended information about the first n results (set n with --count, default is 1)") - database <- databaseFlag + database <- databaseFlag defDb count <- optional $ option auto (short 'n' <> long "count" <> help "Maximum number of results to return (defaults to 10)") query <- some $ argument str (metavar "QUERY") repeat_ <- repeatFlag compare_ <- many $ option str (long "compare" <> metavar "SIG" <> help "Type signatures to compare against") pure $ SearchOpts {..} -generateOpts :: Parser GenerateOpts -generateOpts = do +generateOpts :: FilePath -> Parser GenerateOpts +generateOpts defDb = do download <- optional $ switch (long "download" <> help "Download all files from the web") - database <- databaseFlag + database <- databaseFlag defDb insecure <- switch (long "insecure" <> short 'i' <> help "Allow insecure HTTPS connections") include <- many $ argument str (metavar "PACKAGE" <> help "Packages to include") local_ <- many $ option (fromMaybe "" <$> optional str) (long "local" <> short 'l' <> help "Index local packages and link to local haddock docs") @@ -233,10 +211,10 @@ tcpEndpoint = host = option str (long "host" <> value "*" <> help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host).") port = option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number") -serverOpts :: Parser ServerOpts -serverOpts = do +serverOpts :: FilePath -> Parser ServerOpts +serverOpts defDb = do endpoint <- unixEndpoint <|> tcpEndpoint - database <- databaseFlag + database <- databaseFlag defDb cdn <- option str (value "" <> metavar "URL" <> help "URL prefix to use") logs <- logsFlag local <- switch (long "local" <> help "Allow following file:// links, restricts to 127.0.0.1 Set --host explicitely (including to '*' for any host) to override the localhost-only behaviour") @@ -251,17 +229,17 @@ serverOpts = do no_security_headers <- switch (long "no-security-headers" <> short 'n' <> help "Don't send CSP security headers") pure ServerOpts {..} -replayOpts :: Parser ReplayOpts -replayOpts = do +replayOpts :: FilePath -> Parser ReplayOpts +replayOpts defDb = do logs <- logsFlag - database <- databaseFlag + database <- databaseFlag defDb repeat_ <- repeatFlag scope <- scopeFlag pure ReplayOpts {..} -testOpts :: Parser TestOpts -testOpts = do +testOpts :: FilePath -> Parser TestOpts +testOpts defDb = do deep <- switch (long "deep" <> help "Run extra long tests") - database <- databaseFlag + database <- databaseFlag defDb disable_network_tests <- switch (long "disable-network-tests" <> help "Disables the use of network tests") pure TestOpts {..} From 9b4ab7212dbf0b97993ddb0997e6922b8452bca2 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Wed, 28 Jan 2026 16:08:05 +0100 Subject: [PATCH 8/8] [chore] bump nix dependencies for hoogle h-o deployment --- deploy.nix | 2 +- flake.lock | 7 ++++--- flake.nix | 4 ++-- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/deploy.nix b/deploy.nix index 1d2b4961..fd244b78 100644 --- a/deploy.nix +++ b/deploy.nix @@ -1,5 +1,5 @@ { hoogle, cores ? 4 }: -{ config, lib, pkgs, ... }: +{ lib, pkgs, ... }: # The Plan: # Hoogle serves on a uniquely-named UNIX domain socket which we diff --git a/flake.lock b/flake.lock index bae7c7ed..90a6f4d1 100644 --- a/flake.lock +++ b/flake.lock @@ -20,15 +20,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1738774914, - "narHash": "sha256-4PdqiqwNjd+JHC1o7a9CBASKARTl+FqVH0SW3bcGNAY=", + "lastModified": 1769461804, + "narHash": "sha256-msG8SU5WsBUfVVa/9RPLaymvi5bI8edTavbIq3vRlhI=", "owner": "nixos", "repo": "nixpkgs", - "rev": "66555b199d5b2620d122ab9330205abdb1abb7bd", + "rev": "bfc1b8a4574108ceef22f02bafcf6611380c100d", "type": "github" }, "original": { "owner": "nixos", + "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" } diff --git a/flake.nix b/flake.nix index a9dc07de..2c30145d 100644 --- a/flake.nix +++ b/flake.nix @@ -1,7 +1,7 @@ { description = "haskell.org hoogle deployment"; - inputs.nixpkgs.url = "github:nixos/nixpkgs"; + inputs.nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable"; inputs.flake-utils.url = "github:numtide/flake-utils"; outputs = { self, nixpkgs, flake-utils }: @@ -13,7 +13,7 @@ let hsPkgs = pkgs.haskellPackages.override { overrides = self: super: { - crypton-connection = super.crypton-connection_0_4_3; + hackage-revdeps = super.hackage-revdeps_0_3; }; }; in hsPkgs.callCabal2nix "hoogle" ./. { };