Skip to content

Commit d3ac12a

Browse files
ysangkokysangkok
committed
Make new-browse handle old endpoints
1 parent 84d402a commit d3ac12a

File tree

3 files changed

+6
-229
lines changed

3 files changed

+6
-229
lines changed

‎datafiles/static/new-browse.js

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ const get = () => new Promise((resolve,reject) => {
4343
, searchQuery: state.searchQuery
4444
};
4545
formData.append('browseOptions', JSON.stringify(obj));
46-
fetch('/newpkglist', {method:'POST', body: formData}).then(async (response) => {
46+
fetch('/packages/search', {method:'POST', body: formData}).then(async (response) => {
4747
if (!response.ok) {
4848
const el = d.querySelector("#fatalError");
4949
el.style.display = "block";

‎src/Distribution/Server/Features/Browse.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ initNewBrowseFeature _env =
4444
pure $
4545
(emptyHackageFeature "json")
4646
{ featureResources =
47-
[ (resourceAt "/newpkglist")
47+
[ (resourceAt "/packages/search")
4848
{ resourceDesc =
4949
[ (POST, "Browse and search using a BrowseOptions structure in multipart/form-data encoding")
5050
]

‎src/Distribution/Server/Features/Html.hs

Lines changed: 4 additions & 227 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ import Distribution.Server.Features.Users
2121
import Distribution.Server.Features.DownloadCount
2222
import Distribution.Server.Features.Votes
2323
import Distribution.Server.Features.Search
24-
import Distribution.Server.Features.Search as Search
2524
import Distribution.Server.Features.PreferredVersions
2625
-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies
2726
import Distribution.Server.Features.PackageContents (PackageContentsFeature(..))
@@ -68,9 +67,6 @@ import qualified Data.Map as Map
6867
import qualified Data.Set as Set
6968
import qualified Data.Vector as Vec
7069
import qualified Data.Text as T
71-
import Data.Array (Array, listArray)
72-
import qualified Data.Array as Array
73-
import qualified Data.Ix as Ix
7470
import qualified Data.ByteString.Lazy.Char8 as BS (ByteString, pack)
7571
import qualified Network.URI as URI
7672

@@ -301,7 +297,6 @@ htmlFeature env@ServerEnv{..}
301297
candidates templates
302298
htmlPreferred = mkHtmlPreferred utilities core versions
303299
htmlTags = mkHtmlTags utilities core upload user list tags templates
304-
htmlSearch = mkHtmlSearch utilities core list names cacheBrowseTable templates
305300

306301
htmlResources = concat [
307302
htmlCoreResources htmlCore
@@ -313,7 +308,6 @@ htmlFeature env@ServerEnv{..}
313308
, htmlPreferredResources htmlPreferred
314309
, htmlDownloadsResources htmlDownloads
315310
, htmlTagsResources htmlTags
316-
, htmlSearchResources htmlSearch
317311
-- and user groups. package maintainers, trustees, admins
318312
, htmlGroupResource user (maintainersGroupResource . uploadResource $ upload)
319313
, htmlGroupResource user (trusteesGroupResource . uploadResource $ upload)
@@ -517,7 +511,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
517511
HtmlPreferred{..}
518512
cachePackagesPage
519513
cacheNamesPage
520-
cacheBrowseTable
514+
_cacheBrowseTable
521515
templates
522516
SearchFeature{..}
523517
PackageCandidatesFeature{..}
@@ -553,10 +547,9 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
553547
resourceDesc = [(GET, "Show browsable list of all packages")]
554548
, resourceGet = [("html", serveBrowsePage)]
555549
}
556-
, (resourceAt "/packages/new_browse" ) {
557-
resourceDesc = [(GET, "Show browsable list of all packages")]
558-
, resourceGet = [("html", serveNewBrowsePage)]
559-
}
550+
, (extendResource searchPackagesResource) {
551+
resourceGet = [("html", serveBrowsePage)]
552+
}
560553
, (extendResource $ corePackagesPage cores) {
561554
resourceDesc = [(GET, "Show package index")]
562555
, resourceGet = [("html", const $ readAsyncCache cachePackagesPage)]
@@ -573,14 +566,6 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
573566

574567
serveBrowsePage :: DynamicPath -> ServerPartE Response
575568
serveBrowsePage _dpath = do
576-
template <- getTemplate templates "table-interface.html"
577-
tabledata <- readAsyncCache cacheBrowseTable
578-
return $ toResponse $ template
579-
[ "heading" $= "All packages"
580-
, templateUnescaped "tabledata" tabledata]
581-
582-
serveNewBrowsePage :: DynamicPath -> ServerPartE Response
583-
serveNewBrowsePage _dpath = do
584569
template <- getTemplate templates "new-browse.html"
585570
return $ toResponse $ template
586571
[ "heading" $= "Browse and search packages" ]
@@ -1812,214 +1797,6 @@ mkHtmlTags HtmlUtilities{..}
18121797
tagInPath :: forall m a. (MonadPlus m, FromReqURI a) => DynamicPath -> m a
18131798
tagInPath dpath = maybe mzero return (lookup "tag" dpath >>= fromReqURI)
18141799

1815-
1816-
{-------------------------------------------------------------------------------
1817-
Search
1818-
-------------------------------------------------------------------------------}
1819-
1820-
data HtmlSearch = HtmlSearch {
1821-
htmlSearchResources :: [Resource]
1822-
}
1823-
1824-
mkHtmlSearch :: HtmlUtilities
1825-
-> CoreFeature
1826-
-> ListFeature
1827-
-> SearchFeature
1828-
-> AsyncCache BS.ByteString
1829-
-> Templates
1830-
-> HtmlSearch
1831-
mkHtmlSearch HtmlUtilities{..}
1832-
CoreFeature{..}
1833-
ListFeature{makeItemList}
1834-
SearchFeature{..}
1835-
cacheBrowseTable
1836-
templates =
1837-
HtmlSearch{..}
1838-
where
1839-
htmlSearchResources = [
1840-
(extendResource searchPackagesResource) {
1841-
resourceGet = [("html", servePackageFind)]
1842-
}
1843-
]
1844-
1845-
servePackageFind :: DynamicPath -> ServerPartE Response
1846-
servePackageFind _ = do
1847-
(mtermsStr, mexplain) <-
1848-
queryString $ (,) <$> optional (look "terms")
1849-
<*> optional (look "explain")
1850-
let explain = isJust mexplain
1851-
case mtermsStr of
1852-
Just termsStr | explain
1853-
, terms <- words termsStr, not (null terms) -> do
1854-
params <- queryString getSearchRankParameters
1855-
results <- searchPackagesExplain params terms
1856-
return $ toResponse $ Resource.XHtml $
1857-
hackagePage "Package search" $
1858-
[ toHtml $ paramsForm params termsStr
1859-
, resetParamsForm termsStr
1860-
, toHtml $ explainResults results
1861-
]
1862-
1863-
Just termsStr | terms <- words termsStr -> do
1864-
tabledata <- if null terms
1865-
then readAsyncCache cacheBrowseTable
1866-
else do
1867-
names <- searchPackages terms
1868-
pkgDetails <- liftIO $ makeItemList names
1869-
let rowList = map makeRow pkgDetails
1870-
return . BS.pack . showHtmlFragment $ "" +++ rowList
1871-
template <- getTemplate templates "table-interface.html"
1872-
return $ toResponse $ template
1873-
[ "heading" $= toHtml (searchForm termsStr False)
1874-
, templateUnescaped "tabledata" tabledata
1875-
, "footer" $= alternativeSearchTerms termsStr]
1876-
1877-
_ ->
1878-
return $ toResponse $ Resource.XHtml $
1879-
hackagePage "Text search" $
1880-
[ toHtml $ searchForm "" explain
1881-
, alternativeSearch
1882-
]
1883-
where
1884-
searchForm termsStr explain =
1885-
[ h2 << "Package search"
1886-
, form ! [XHtml.method "GET", action "/packages/search"] <<
1887-
[ input ! [value termsStr, name "terms", identifier "terms"]
1888-
, toHtml " "
1889-
, input ! [thetype "submit", value "Search"]
1890-
, if explain then input ! [thetype "hidden", name "explain"]
1891-
else noHtml
1892-
]
1893-
]
1894-
1895-
alternativeSearch =
1896-
paragraph <<
1897-
[ toHtml "Alternatively, if you are looking for a particular function then try "
1898-
, anchor ! [href hoogleBaseLink] << "Hoogle"
1899-
]
1900-
alternativeSearchTerms termsStr =
1901-
paragraph <<
1902-
[ toHtml "Alternatively, if you are looking for a particular function then try "
1903-
, anchor ! [href (hoogleLink termsStr)] << "Hoogle"
1904-
]
1905-
hoogleBaseLink = "http://www.haskell.org/hoogle/"
1906-
hoogleLink termsStr = "http://www.haskell.org/hoogle/?hoogle=" <> termsStr
1907-
1908-
explainResults :: (Maybe PackageName, [(Search.Explanation PkgDocField PkgDocFeatures T.Text, PackageName)]) -> [Html]
1909-
explainResults (exactMatch, results) =
1910-
[ h2 << "Results"
1911-
, h3 << "Exact Matches"
1912-
, maybe noHtml (toHtml . display) exactMatch
1913-
, case results of
1914-
[] -> noHtml
1915-
((explanation1, _):_) ->
1916-
table ! [ border 1 ] <<
1917-
( ( tr << tableHeader explanation1)
1918-
: [ tr << tableRow explanation pkgname
1919-
| (explanation, pkgname) <- results ])
1920-
]
1921-
where
1922-
tableHeader Search.Explanation{..} =
1923-
[ th << "package", th << "overall score" ]
1924-
++ [ th << (show term ++ " score")
1925-
| (term, _score) <- termScores ]
1926-
++ [ th << (show term ++ " " ++ show field ++ " score")
1927-
| (term, fieldScores) <- termFieldScores
1928-
, (field, _score) <- fieldScores ]
1929-
++ [ th << (show feature ++ " score")
1930-
| (feature, _score) <- nonTermScores ]
1931-
1932-
tableRow Search.Explanation{..} pkgname =
1933-
[ td << display pkgname, td << show overallScore ]
1934-
++ [ td << show score
1935-
| (_term, score) <- termScores ]
1936-
++ [ td << show score
1937-
| (_term, fieldScores) <- termFieldScores
1938-
, (_field, score) <- fieldScores ]
1939-
++ [ td << show score
1940-
| (_feature, score) <- nonTermScores ]
1941-
1942-
getSearchRankParameters = do
1943-
let defaults = defaultSearchRankParameters
1944-
k1 <- lookRead "k1" `mplus` pure (paramK1 defaults)
1945-
bs <- sequence
1946-
[ lookRead ("b" ++ show field)
1947-
`mplus` pure (paramB defaults field)
1948-
| field <- Ix.range (minBound, maxBound :: PkgDocField) ]
1949-
ws <- sequence
1950-
[ lookRead ("w" ++ show field)
1951-
`mplus` pure (paramFieldWeights defaults field)
1952-
| field <- Ix.range (minBound, maxBound :: PkgDocField) ]
1953-
fs <- sequence
1954-
[ lookRead ("w" ++ show feature)
1955-
`mplus` pure (paramFeatureWeights defaults feature)
1956-
| feature <- Ix.range (minBound, maxBound :: PkgDocFeatures) ]
1957-
let barr, warr :: Array PkgDocField Float
1958-
barr = listArray (minBound, maxBound) bs
1959-
warr = listArray (minBound, maxBound) ws
1960-
farr = listArray (minBound, maxBound) fs
1961-
return defaults {
1962-
paramK1 = k1,
1963-
paramB = (barr Array.!),
1964-
paramFieldWeights = (warr Array.!),
1965-
paramFeatureWeights = (farr Array.!)
1966-
}
1967-
1968-
paramsForm SearchRankParameters{..} termsStr =
1969-
[ h2 << "Package search (tuning & explanation)"
1970-
, form ! [XHtml.method "GET", action "/packages/search"] <<
1971-
[ input ! [value termsStr, name "terms", identifier "terms"]
1972-
, toHtml " "
1973-
, input ! [thetype "submit", value "Search"]
1974-
, input ! [thetype "hidden", name "explain"]
1975-
, simpleTable [] [] $
1976-
makeInput [thetype "text", value (show paramK1)] "k1" "K1 parameter"
1977-
: [ makeInput [thetype "text", value (show (paramB field))]
1978-
("b" ++ fieldname)
1979-
("B param for " ++ fieldname)
1980-
++ makeInput [thetype "text", value (show (paramFieldWeights field)) ]
1981-
("w" ++ fieldname)
1982-
("Weight for " ++ fieldname)
1983-
| field <- Ix.range (minBound, maxBound :: PkgDocField)
1984-
, let fieldname = show field
1985-
]
1986-
++ [ makeInput [thetype "text", value (show (paramFeatureWeights feature)) ]
1987-
("w" ++ featurename)
1988-
("Weight for " ++ featurename)
1989-
| feature <- Ix.range (minBound, maxBound :: PkgDocFeatures)
1990-
, let featurename = show feature ]
1991-
]
1992-
]
1993-
resetParamsForm termsStr =
1994-
let SearchRankParameters{..} = defaultSearchRankParameters in
1995-
form ! [XHtml.method "GET", action "/packages/search"] <<
1996-
(concat $
1997-
[ input ! [ thetype "submit", value "Reset parameters" ]
1998-
, input ! [ thetype "hidden", name "terms", value termsStr ]
1999-
, input ! [ thetype "hidden", name "explain" ]
2000-
, input ! [ thetype "hidden", name "k1", value (show paramK1) ] ]
2001-
: [ [ input ! [ thetype "hidden"
2002-
, name ("b" ++ fieldname)
2003-
, value (show (paramB field))
2004-
]
2005-
, input ! [ thetype "hidden"
2006-
, name ("w" ++ fieldname)
2007-
, value (show (paramFieldWeights field))
2008-
]
2009-
]
2010-
| field <- Ix.range (minBound, maxBound :: PkgDocField)
2011-
, let fieldname = show field
2012-
]
2013-
++ [ [ input ! [ thetype "hidden"
2014-
, name ("w" ++ featurename)
2015-
, value (show (paramFeatureWeights feature))
2016-
]
2017-
]
2018-
| feature <- Ix.range (minBound, maxBound :: PkgDocFeatures)
2019-
, let featurename = show feature
2020-
])
2021-
2022-
20231800
{-------------------------------------------------------------------------------
20241801
Groups
20251802
-------------------------------------------------------------------------------}

0 commit comments

Comments
 (0)