diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Server.hs | 97 |
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 |