diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Server.hs | 106 |
1 files changed, 100 insertions, 6 deletions
diff --git a/app/Server.hs b/app/Server.hs index 62e556f..353f808 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -15,6 +15,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where @@ -29,21 +30,23 @@ import Control.Exception , throwIO , try ) +import Control.Lens hiding(children,index) import Control.Monad (foldM, unless) import Control.Monad.Except (ExceptT(..)) -import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Reader (MonadIO, MonadReader, ReaderT(..), asks, liftIO) +import Control.Monad.State.Strict (StateT(..)) import qualified Data.Aeson as A +import qualified Data.Aeson.Lens as AL import qualified Data.ByteString as BS -import qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as BSS import Data.Default (def) import Data.Either (lefts, rights) import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable) -import qualified Data.IntervalMap.Strict as IVM import Data.IntervalMap.Interval (Interval(..), subsumes) +import qualified Data.IntervalMap.Strict as IVM import qualified Data.List as L import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, mapMaybe) @@ -75,6 +78,7 @@ import GHC.Exts (Down(..), groupWith) import GHC.Generics (Generic) import qualified HaskellCodeExplorer.Types as HCE import Network.HTTP.Types (hContentEncoding, hContentType, status200, status404) +import Network.URI.Encode (encode) import Network.Mime (defaultMimeLookup) import Network.Wai ( Application @@ -86,6 +90,7 @@ import Network.Wai , responseLBS ) import Network.Wai.Handler.Warp (run) +import qualified Network.Wreq as Wreq import Network.Wai.Middleware.RequestLogger ( Destination(..) , OutputFormat(..) @@ -128,6 +133,7 @@ import Servant , addHeader , err404 , err500 + , err502 , errBody , serve ) @@ -175,6 +181,7 @@ data ServerConfig = ServerConfig , configJsDistDirectory :: !(Maybe String) , configMaxPerPage :: !Int , configStore :: !(Maybe Store) + , configUseHoogleApi :: !Bool } deriving (Show, Eq) data PackagesPath @@ -249,7 +256,11 @@ configParser = strOption (long "use-store-mmap" <> help "Use existing key-value store. mmap 'values' file." <> - metavar "PATH_TO_DATA_DIRECTORY"))) + metavar "PATH_TO_DATA_DIRECTORY"))) <*> + 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)") -------------------------------------------------------------------------------- -- Loading packages @@ -914,6 +925,7 @@ type API = GetAllPackages :<|> GetIdentifiers :<|> GetGlobalReferences :<|> GetGlobalIdentifiers + :<|> GetHoogleDocs type GetAllPackages = "api" :> "packages" :> Get '[JSON] AllPackages @@ -959,7 +971,14 @@ type GetGlobalIdentifiers = "api" :> "globalIdentifiers" :> QueryParam "page" Int :> QueryParam "per_page" Int :> Get '[JSON] (Headers '[Header "Link" T.Text,Header "X-Total-Count" Int] - [HCE.ExternalIdentifierInfo]) + [HCE.ExternalIdentifierInfo]) + +type GetHoogleDocs = "api" :> "hoogleDocs" + :> Capture "packageId" PackageId + :> Capture "moduleName" HCE.HaskellModuleName + :> Capture "entity" HoogleItemSort + :> Capture "name" T.Text + :> Get '[JSON] T.Text instance AllCTRender '[ JSON] AllPackages where handleAcceptH _ _ (AllPackages bytestring) = @@ -972,6 +991,11 @@ instance FromHttpApiData HCE.LocatableEntity where parseQueryParam "Mod" = Right HCE.Mod parseQueryParam val = Left $ T.append "Incorrect LocatableEntity : " val +instance FromHttpApiData HoogleItemSort where + parseQueryParam "Val" = Right Val + parseQueryParam "Typ" = Right Typ + parseQueryParam val = Left $ T.append "Incorrect HoogleItemSort : " val + instance ToHttpApiData HCE.LocatableEntity where toUrlPiece HCE.Val = "ValueEntity" toUrlPiece HCE.Typ = "TypeEntity" @@ -1474,6 +1498,75 @@ findGlobalIdentifiers query' mbPage mbPerPage = do addHeaders = addHeader linkHeader . addHeader totalCount return . addHeaders . paginatedItems $ paginatedIdentifiers +data HoogleResultItem = HoogleResultItem + { sort :: HoogleItemSort + , moduleName :: T.Text + , htmlDocs :: T.Text + } deriving (Show, Eq) + +data HoogleItemSort + = Val + | Typ + deriving (Show, Eq) + +valueToHoogleResultItem :: A.Value -> Maybe HoogleResultItem +valueToHoogleResultItem value = + let mbHtmlDocs = value ^? AL.key "docs" . AL._String + mbModuleName = value ^? AL.key "module" . AL.key "name" . AL._String + urlToSort :: T.Text -> Maybe HoogleItemSort + urlToSort url + | T.isInfixOf "#v" url = Just Val + urlToSort url + | T.isInfixOf "#t" url = Just Typ + urlToSort _ = Nothing + mbResultSort = value ^? AL.key "url" . AL._String >>= urlToSort + in HoogleResultItem <$> mbResultSort <*> mbModuleName <*> mbHtmlDocs + +hoogleApiHost :: String +hoogleApiHost = "https://hoogle.haskell.org/" + +getHoogleDocs :: + PackageId + -> HCE.HaskellModuleName + -> HoogleItemSort + -> T.Text + -> ReaderT Environment IO T.Text +getHoogleDocs packageId (HCE.HaskellModuleName moduleName) itemSort name + | Just (packageName, _mbVersion) <- parsePackageId packageId = do + useHoogle <- asks (configUseHoogleApi . 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" + error502 e = + throwServantError $ + err502 {errBody = BSL.fromStrict $ BSC.pack $ show e} + response <- liftIO $ handleSync error502 (Wreq.get url) + let body = response ^. Wreq.responseBody + case A.decode body of + Just (value :: A.Value) -> + case value of + A.Array vector -> + let items = mapMaybe valueToHoogleResultItem $ V.toList vector + findItem :: Bool -> [HoogleResultItem] -> Maybe HoogleResultItem + findItem exactModuleMatch = + L.find + (\HoogleResultItem {sort = s, moduleName = m} -> + s == itemSort && (exactModuleMatch || m == moduleName)) + in case findItem True items <|> findItem False items of + Just item -> return $ htmlDocs item + _ -> error404 "" + _ -> + error500 $ + BSL.append "Unexpected JSON response from hoogle.haskell.org" body + Nothing -> + error500 $ + BSL.append "Unexpected response from hoogle.haskell.org: " body +getHoogleDocs packageId _ _ _ = + error404 $ + BSL.append "Incorrect package id: " (toLazyBS $ getPackageId packageId) + paginateItems :: Maybe Int -> Maybe Int @@ -1737,7 +1830,8 @@ server env = getReferences :<|> findIdentifiers :<|> getGlobalReferences :<|> - findGlobalIdentifiers) + findGlobalIdentifiers :<|> + getHoogleDocs) where toServantHandler :: ReaderT Environment IO a -> Handler a toServantHandler ma = Handler . ExceptT . try . runReaderT ma $ env |