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