Update search results to link to stackage.org

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

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 "</0>" "" $ 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

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