aboutsummaryrefslogtreecommitdiff
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/Server.hs97
1 files changed, 74 insertions, 23 deletions
diff --git a/app/Server.hs b/app/Server.hs
index abe4958..f6e1d6d 100644
--- a/app/Server.hs
+++ b/app/Server.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -247,8 +248,18 @@ newtype PackageName = PackageName
instance A.ToJSON PackageVersions
+type GlobalReferenceMap = HM.HashMap HCE.ExternalId (S.Set GlobalReferences)
+
+data GlobalReferences = GlobalReferences
+ { count :: Int
+ , packageId :: T.Text
+ } deriving (Show, Eq, Ord, Generic)
+
+instance A.ToJSON GlobalReferences
+
loadPackages ::
- ServerConfig -> IO (Maybe (PackageMap, PackagePathMap, [PackageVersions]))
+ ServerConfig
+ -> IO (Maybe (PackageMap, PackagePathMap, [PackageVersions], GlobalReferenceMap))
loadPackages config = do
packageDirectories <-
case configPackagesPath config of
@@ -296,11 +307,33 @@ loadPackages config = do
in HM.insert key path hMap)
HM.empty
loadedPackages
+ globalReferenceMap =
+ L.foldl'
+ (\hMap (packageInfo, _path) ->
+ let references =
+ HM.map
+ (\spans ->
+ S.singleton
+ (GlobalReferences
+ (S.size spans)
+ (HCE.packageIdToText packageId))) .
+ HCE.externalIdOccMap $
+ packageInfo
+ packageId =
+ HCE.id
+ (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)
+ in HM.unionWith S.union references hMap)
+ HM.empty
+ loadedPackages
packageMapCompacted <- ghcCompact packageMap
packagePathMapCompacted <- ghcCompact packagePathMap
packageVersionsCompacted <- ghcCompact packageVersions
+ globalReferenceMapCompacted <- ghcCompact globalReferenceMap
return . Just $
- (packageMapCompacted, packagePathMapCompacted, packageVersionsCompacted)
+ ( packageMapCompacted
+ , packagePathMapCompacted
+ , packageVersionsCompacted
+ , globalReferenceMapCompacted)
else return Nothing
where
packageName :: HCE.PackageInfo HCE.CompactModuleInfo -> PackageName
@@ -312,7 +345,7 @@ loadPackages config = do
packageVersion =
HCE.version . (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId)
-ghcCompact :: forall a. a -> IO a
+ghcCompact :: forall a. a -> IO a
ghcCompact =
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
(fmap C.getCompact . C.compact)
@@ -377,6 +410,7 @@ type API = GetAllPackages
:<|> GetExpressions
:<|> GetReferences
:<|> GetIdentifiers
+ :<|> GetGlobalReferences
type GetAllPackages = "api" :> "packages" :> Get '[JSON] AllPackages
@@ -399,7 +433,7 @@ type GetExpressions = "api" :> "expressions"
type GetReferences = "api" :> "references"
:> Capture "packageId" PackageId
- :> Capture "name" HCE.ExternalId
+ :> Capture "externalId" HCE.ExternalId
:> QueryParam "page" Int
:> QueryParam "per_page" Int
:> Get '[JSON] (Headers '[Header "Link" T.Text,Header "X-Total-Count" Int]
@@ -413,6 +447,10 @@ type GetIdentifiers = "api" :> "identifiers"
:> Get '[JSON] (Headers '[Header "Link" T.Text,Header "X-Total-Count" Int]
[HCE.ExternalIdentifierInfo])
+type GetGlobalReferences = "api" :> "globalReferences"
+ :> Capture "externalId" HCE.ExternalId
+ :> Get '[JSON] [GlobalReferences]
+
instance AllCTRender '[ JSON] AllPackages where
handleAcceptH _ _ (AllPackages bytestring) =
Just ("application/json", bytestring)
@@ -459,6 +497,7 @@ data Environment = Environment
{ envLogger :: !LoggerSet
, envPackageMap :: !PackageMap
, envPackageVersions :: !AllPackages
+ , envGlobalReferenceMap :: !GlobalReferenceMap
, envConfig :: !ServerConfig
}
@@ -646,6 +685,12 @@ initializePagination mbPage mbPerPage = do
Nothing -> maxPerPage
return (fromIntegral page, fromIntegral perPage)
+getGlobalReferences ::
+ HCE.ExternalId -> ReaderT Environment IO [GlobalReferences]
+getGlobalReferences externalId = do
+ refMap <- asks envGlobalReferenceMap
+ return $ maybe [] S.toDescList (HM.lookup externalId refMap)
+
getReferences ::
PackageId
-> HCE.ExternalId
@@ -656,14 +701,8 @@ getReferences packageId externalId mbPage mbPerPage =
withPackageInfo packageId $ \packageInfo ->
case S.toList <$> HM.lookup externalId (HCE.externalIdOccMap packageInfo) of
Just references -> do
- (page, perPage) <- initializePagination mbPage mbPerPage
- pagination <- mkPagination perPage page
- let totalCount = L.length references
- paginatedReferences <-
- paginate
- pagination
- (fromIntegral totalCount)
- (\offset limit -> return . L.take limit . L.drop offset $ references)
+ (paginatedReferences, page, perPage, totalCount) <-
+ paginateItems mbPage mbPerPage references
let url =
T.append "/" $
toUrlPiece $
@@ -753,7 +792,7 @@ buildHtmlCodeSnippet sourceLines lineNumber positions =
case mbId of
Just _ -> Html.b (Html.toHtml text)
Nothing -> Html.toHtml text) $
- HCE.tokenize line (map (\pos -> (pos, ())) positions)
+ HCE.tokenize line (map (, ()) positions)
findIdentifiers ::
PackageId
@@ -769,14 +808,8 @@ findIdentifiers packageId query mbPage mbPerPage =
S.toList $
HCE.match (T.unpack query) (HCE.externalIdInfoMap packageInfo)
| otherwise = []
- (page, perPage) <- initializePagination mbPage mbPerPage
- let totalCount = L.length identifiers
- pagination <- mkPagination perPage page
- paginatedIdentifiers <-
- paginate
- pagination
- (fromIntegral totalCount)
- (\offset limit -> return . L.take limit . L.drop offset $ identifiers)
+ (paginatedIdentifiers, page, perPage, totalCount) <-
+ paginateItems mbPage mbPerPage identifiers
let url =
T.append "/" $
toUrlPiece $
@@ -795,6 +828,22 @@ findIdentifiers packageId query mbPage mbPerPage =
addHeaders = addHeader linkHeader . addHeader totalCount
return . addHeaders . paginatedItems $ paginatedIdentifiers
+paginateItems ::
+ Maybe Int
+ -> Maybe Int
+ -> [a]
+ -> ReaderT Environment IO (Paginated a, Natural, Natural, Int)
+paginateItems mbPage mbPerPage items = do
+ (page, perPage) <- initializePagination mbPage mbPerPage
+ let totalCount = L.length items
+ pagination <- mkPagination perPage page
+ paginated <-
+ paginate
+ pagination
+ (fromIntegral totalCount)
+ (\offset limit -> return . L.take limit . L.drop offset $ items)
+ return (paginated, page, perPage, totalCount)
+
error404 :: BSL.ByteString -> ReaderT Environment IO a
error404 body = throwServantError $ err404 {errBody = body}
@@ -995,7 +1044,8 @@ server env =
getDefinitionSite :<|>
getExpressions :<|>
getReferences :<|>
- findIdentifiers)
+ findIdentifiers :<|>
+ getGlobalReferences)
where
toServantHandler :: ReaderT Environment IO a -> Handler a
toServantHandler ma = Handler . ExceptT . try . runReaderT ma $ env
@@ -1015,7 +1065,7 @@ main = do
print config
packages <- loadPackages config
case packages of
- Just (packageMap, packagePathMap, packageVersions) -> do
+ Just (packageMap, packagePathMap, packageVersions,globalReferenceMap) -> do
loggerSet <-
case configLog config of
HCE.ToFile logfile -> newFileLoggerSet defaultBufSize logfile
@@ -1031,6 +1081,7 @@ main = do
loggerSet
packageMap
(AllPackages . A.encode $ packageVersions)
+ globalReferenceMap
config
static =
if configServeStaticFiles config