From cb93e5472974a19eaecb9c580d1993004111294d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 14 Jun 2016 16:47:17 +0200 Subject: [PATCH] Update search results to link to stackage.org --- Handler/Haddock.hs | 115 +++++++++++++++++++++++++------------------ Handler/Hoogle.hs | 40 +++++++++++---- Stackage/Database.hs | 17 +++++++ 3 files changed, 113 insertions(+), 59 deletions(-) diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index b0d81d0..1f9910e 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -20,57 +20,74 @@ shouldRedirect = False getHaddockR :: SnapName -> [Text] -> Handler TypedContent getHaddockR slug rest - | shouldRedirect = redirect $ makeURL slug rest - | final:_ <- reverse rest, ".html" `isSuffixOf` final = track "Handler.Haddock.getHaddockR" $ do + | shouldRedirect = do + result <- redirectWithVersion slug rest + case result of + Just route -> redirect route + Nothing -> redirect $ makeURL slug rest + | final:_ <- reverse rest, ".html" `isSuffixOf` final = do render <- getUrlRender - - let stylesheet = render' $ StaticR haddock_style_css - script = render' $ StaticR haddock_script_js - bootstrap = render' $ StaticR haddock_bootstrap_css - jquery = render' $ StaticR haddock_jquery_js - render' = return . ContentText . render - - addExtra t@(EventEndElement "head") = - [ EventBeginElement "link" - [ ("rel", [ContentText "stylesheet"]) - , ("href", bootstrap) - ] - , EventEndElement "link" - , EventBeginElement "link" - [ ("rel", [ContentText "stylesheet"]) - , ("href", [ContentText "https://fonts.googleapis.com/css?family=Open+Sans"]) - ] - , EventEndElement "link" - , EventBeginElement "link" - [ ("rel", [ContentText "stylesheet"]) - , ("href", stylesheet) - ] - , EventEndElement "link" - , EventBeginElement "script" - [ ("src", jquery) - ] - , EventEndElement "script" - , EventBeginElement "script" - [ ("src", script) - ] - , EventEndElement "script" - , t - ] - addExtra t@(EventBeginElement "body" _) = [t] ++ nav - addExtra t = [t] - - req <- parseUrl $ unpack $ makeURL slug rest - (_, res) <- acquireResponse req >>= allocateAcquire - - doc <- responseBody res - $$ eventConduit - =$ concatMapC addExtra - =$ mapC (Nothing, ) - =$ fromEvents - - sendResponse $ toHtml doc + result <- redirectWithVersion slug rest + case result of + Just route -> redirect route + Nothing -> do + let stylesheet = render' $ StaticR haddock_style_css + script = render' $ StaticR haddock_script_js + bootstrap = render' $ StaticR haddock_bootstrap_css + jquery = render' $ StaticR haddock_jquery_js + render' = return . ContentText . render + addExtra t@(EventEndElement "head") = + [ EventBeginElement "link" + [ ("rel", [ContentText "stylesheet"]) + , ("href", bootstrap) + ] + , EventEndElement "link" + , EventBeginElement "link" + [ ("rel", [ContentText "stylesheet"]) + , ("href", [ContentText "https://fonts.googleapis.com/css?family=Open+Sans"]) + ] + , EventEndElement "link" + , EventBeginElement "link" + [ ("rel", [ContentText "stylesheet"]) + , ("href", stylesheet) + ] + , EventEndElement "link" + , EventBeginElement "script" + [ ("src", jquery) + ] + , EventEndElement "script" + , EventBeginElement "script" + [ ("src", script) + ] + , EventEndElement "script" + , t + ] + addExtra t@(EventBeginElement "body" _) = [t] ++ nav + addExtra t = [t] + req <- parseUrl $ unpack $ makeURL slug rest + (_, res) <- acquireResponse req >>= allocateAcquire + doc <- responseBody res + $$ eventConduit + =$ concatMapC addExtra + =$ mapC (Nothing, ) + =$ fromEvents + sendResponse $ toHtml doc | otherwise = redirect $ makeURL slug rest +redirectWithVersion + :: (GetStackageDatabase m,MonadHandler m,RedirectUrl (HandlerSite m) (Route App)) + => SnapName -> [Text] -> m (Maybe (Route App)) +redirectWithVersion slug rest = + case rest of + [pkg,file] -> do + Entity sid _ <- lookupSnapshot slug >>= maybe notFound return + mversion <- getPackageVersionBySnapshot sid pkg + case mversion of + Nothing -> error "That package is not part of this snapshot." + Just version -> do + return (Just (HaddockR slug [pkg <> "-" <> version, file])) + _ -> return Nothing + nav :: [Event] nav = el "nav" @@ -100,6 +117,6 @@ nav = close = [EventEndElement name] getHaddockBackupR :: [Text] -> Handler () -getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat +getHaddockBackupR rest = redirect $ concat $ "https://s3.amazonaws.com/haddock.stackage.org" : map (cons '/') rest diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index c5d7c37..600e330 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -39,6 +39,7 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do -- Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 lock <- appHoogleLock <$> getYesod + urlRender <- getUrlRender HoogleQueryOutput results mtotalCount <- case mquery of Just query -> do @@ -53,7 +54,7 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do $ const $ Hoogle.withDatabase dbPath -- NB! I got a segfault when I didn't force with $! - $ \db -> return $! runHoogleQuery db input + $ \db -> return $! runHoogleQuery urlRender name db input Nothing -> return $ HoogleQueryOutput [] Nothing let queryText = fromMaybe "" mquery pageLink p = (SnapshotR name HoogleR @@ -126,8 +127,12 @@ instance NFData HoogleResult where rnf = genericRnf instance NFData PackageLink where rnf = genericRnf instance NFData ModuleLink where rnf = genericRnf -runHoogleQuery :: Hoogle.Database -> HoogleQueryInput -> HoogleQueryOutput -runHoogleQuery hoogledb HoogleQueryInput {..} = +runHoogleQuery :: (Route App -> Text) + -> SnapName + -> Hoogle.Database + -> HoogleQueryInput + -> HoogleQueryOutput +runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} = HoogleQueryOutput targets mcount where allTargets = Hoogle.searchDatabase hoogledb query @@ -144,15 +149,30 @@ runHoogleQuery hoogledb HoogleQueryInput {..} = | otherwise = limitedLength (x + 1) rest fixResult Hoogle.Target {..} = HoogleResult - { hrURL = targetURL - , hrSources = toList $ do - (pname, purl) <- targetPackage - (mname, murl) <- targetModule - let p = PackageLink pname purl - m = ModuleLink mname murl - Just (p, [m]) + { hrURL = case sources of + [(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL + _ -> targetURL + , hrSources = sources , hrTitle = -- FIXME find out why these replaces are necessary unpack $ T.replace "<0>" "" $ T.replace "" "" $ pack targetItem , hrBody = targetDocs } + where sources = toList $ do + (pname, _) <- targetPackage + (mname, _) <- targetModule + let p = PackageLink pname (makePackageLink pname) + m = ModuleLink + mname + (T.unpack + (renderUrl + (haddockUrl + snapshot + (T.pack pname) + (T.pack mname)))) + Just (p, [m]) + haddockAnchorFromUrl = + ('#':) . reverse . takeWhile (/='#') . reverse + +makePackageLink :: String -> String +makePackageLink pkg = "/package/" ++ pkg diff --git a/Stackage/Database.hs b/Stackage/Database.hs index a1da774..24a6f08 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -15,6 +15,7 @@ module Stackage.Database , PackageListingInfo (..) , getAllPackages , getPackages + , getPackageVersionBySnapshot , createStackageDatabase , openStackageDatabase , ModuleListingInfo (..) @@ -526,6 +527,22 @@ getPackages sid = liftM (map toPLI) $ run $ do , pliIsCore = isCore } +getPackageVersionBySnapshot + :: GetStackageDatabase m + => SnapshotId -> Text -> m (Maybe Text) +getPackageVersionBySnapshot sid name = liftM (listToMaybe . map toPLI) $ run $ do + E.select $ E.from $ \(p,sp) -> do + E.where_ $ + (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&. + (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&. + (E.lower_ (p E.^. PackageName) E.==. E.lower_ (E.val name)) + E.orderBy [E.asc $ E.lower_ $ p E.^. PackageName] + return + ( sp E.^. SnapshotPackageVersion + ) + where + toPLI (E.Value version) = version + data ModuleListingInfo = ModuleListingInfo { mliName :: !Text , mliPackageVersion :: !Text