From c443bec3c0dcda07469a214f4f009394321ee619 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Mon, 13 Jun 2022 17:06:46 +1000
Subject: Adding cli options / config to use specified hoogle api
- and an option to disable https cert check for hoogle api
---
app/Server.hs | 33 +++++++++++++++++++++++++--------
haskell-code-explorer.cabal | 3 +++
2 files changed, 28 insertions(+), 8 deletions(-)
diff --git a/app/Server.hs b/app/Server.hs
index 9eaeca1..07f1e45 100644
--- a/app/Server.hs
+++ b/app/Server.hs
@@ -39,6 +39,7 @@ import qualified Data.Aeson.Lens as AL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy.UTF8 as BLU
import qualified Data.ByteString.Short as BSS
import Data.Default (def)
import Data.Either (lefts, rights)
@@ -61,7 +62,6 @@ import Data.Pagination
, paginatedPagesTotal
)
import Data.Proxy (Proxy(..))
-import Data.Semigroup ((<>))
import qualified Data.Serialize as Serialize
import qualified Data.Set as S
import qualified Data.Text as T
@@ -72,6 +72,8 @@ import Data.Version (Version(..))
import GHC.Exts (Down(..), groupWith)
import GHC.Generics (Generic)
import qualified HaskellCodeExplorer.Types as HCE
+import Network.Connection (TLSSettings (..))
+import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types (hContentEncoding, hContentType, status200, status404)
import Network.URI.Encode (encode)
import Network.Mime (defaultMimeLookup)
@@ -177,6 +179,8 @@ data ServerConfig = ServerConfig
, configMaxPerPage :: !Int
, configStore :: !(Maybe Store)
, configUseHoogleApi :: !Bool
+ , configHoogleApi :: !String
+ , configHoogleApiDisableCertCheck :: !Bool
} deriving (Show, Eq)
data PackagesPath = PackagesPath
@@ -256,7 +260,17 @@ configParser =
switch
(long "use-hoogle-api" <>
help
- "Use public Hoogle JSON API (https://github.com/ndmitchell/hoogle/blob/3dbf68bfd701f942d3af2e6debb74a0a78cd392e/docs/API.md#json-api) to get documentation for not indexed packages (disabled by default)")
+ "Use public Hoogle JSON API to get documentation for not indexed packages (disabled by default)") <*>
+ (pure "https://hoogle.haskell.org" <|>
+ strOption
+ (long "hoogle-api" <>
+ help "host of Hoogle API, defaulting to the public instance https://hoogle.haskell.org." <>
+ metavar "HOOGLE_API")) <*>
+ switch
+ (long "disable-hoogle-api-cert-check" <>
+ help
+ "Disable https certificate check for hoogle API (checks cert by default)")
+
parsePackagesPath :: Parser FilePath -> Parser [FilePath] -> Parser PackagesPath
parsePackagesPath parseDir parsePaths =
@@ -1530,9 +1544,6 @@ valueToHoogleResultItem value =
mbResultSort = value ^? AL.key "url" . AL._String >>= urlToSort
in HoogleResultItem <$> mbResultSort <*> mbModuleName <*> mbHtmlDocs
-hoogleApiHost :: String
-hoogleApiHost = "https://hoogle.haskell.org/"
-
getHoogleDocs ::
PackageId
-> HCE.HaskellModuleName
@@ -1542,15 +1553,21 @@ getHoogleDocs ::
getHoogleDocs packageId (HCE.HaskellModuleName moduleName) itemSort name
| Just (packageName, _mbVersion) <- parsePackageId packageId = do
useHoogle <- asks (configUseHoogleApi . envConfig)
+ hoogleApiHost <- asks (configHoogleApi . envConfig)
+ disableCertCheck <- asks (configHoogleApiDisableCertCheck . envConfig)
unless useHoogle $ error404 "Hoogle API is disabled"
let hoogleQuery =
T.unpack name ++
" is:exact package:" ++ T.unpack (getPackageName packageName)
- url = hoogleApiHost ++ "?hoogle=" ++ encode hoogleQuery ++ "&mode=json"
+ url = hoogleApiHost </> "?hoogle=" ++ encode hoogleQuery ++ "&mode=json"
error502 e =
throwServantError $
err502 {errBody = BSL.fromStrict $ BSC.pack $ show e}
- response <- liftIO $ handleSync error502 (Wreq.get url)
+ opts = Wreq.defaults & Wreq.manager .~
+ Left (mkManagerSettings
+ (TLSSettingsSimple disableCertCheck False False) Nothing)
+
+ response <- liftIO $ handleSync error502 (Wreq.getWith opts url)
let body = response ^. Wreq.responseBody
case A.decode body of
Just (value :: A.Value) ->
@@ -1570,7 +1587,7 @@ getHoogleDocs packageId (HCE.HaskellModuleName moduleName) itemSort name
BSL.append "Unexpected JSON response from hoogle.haskell.org" body
Nothing ->
error500 $
- BSL.append "Unexpected response from hoogle.haskell.org: " body
+ "Unexpected response from " <> BLU.fromString hoogleApiHost <> ": " <> body
getHoogleDocs packageId _ _ _ =
error404 $
BSL.append "Incorrect package id: " (toLazyBS $ getPackageId packageId)
diff --git a/haskell-code-explorer.cabal b/haskell-code-explorer.cabal
index e2d18e9..2d68dfe 100644
--- a/haskell-code-explorer.cabal
+++ b/haskell-code-explorer.cabal
@@ -85,6 +85,7 @@ executable haskell-code-server
, base
, bytestring
, cereal
+ , connection
, containers
, deepseq
, directory
@@ -105,6 +106,7 @@ executable haskell-code-server
, wai-extra
, wai-middleware-static
, warp
+ , http-client-tls
, http-types
, http-api-data
, fast-logger
@@ -116,6 +118,7 @@ executable haskell-code-server
, mmap
, lens
, uri-encode
+ , utf8-string
, lens-aeson
, wreq
if impl(ghc >= 8.4.3)
--
cgit v1.2.3