Adding cli options / config to use specified hoogle api

- and an option to disable https cert check for hoogle api

1 files changed, 25 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)