From e54b3f80a6796d4e5851a5d83d89ddf46ee8d0ce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 May 2016 17:20:25 +0300 Subject: [PATCH 01/12] Include Hoogle 5 via Git repo (does not compile) --- stack.yaml | 6 ++++++ stackage-server.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 052062e..faff7b3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,10 @@ resolver: lts-5.15 +packages: +- . +- location: + git: https://github.com/ndmitchell/hoogle.git + commit: 779e04ed20a556bbb92789815ea60068fe188891 + extra-dep: true image: container: name: fpco/stackage-server diff --git a/stackage-server.cabal b/stackage-server.cabal index f478a15..130f255 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -158,7 +158,7 @@ library , haddock-library >= 1.2.0 && < 1.3 , async >= 2.1 && < 2.2 , yesod-gitrepo >= 0.2 && < 0.3 - , hoogle >= 4.2 && < 4.3 + , hoogle , spoon >= 0.3 && < 0.4 , deepseq >= 1.4 && < 1.5 , deepseq-generics >= 0.1 && < 0.2 From c1e16d8e1ab827b351bfdced1db604fee667e11b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Jun 2016 20:26:38 +0300 Subject: [PATCH 02/12] Get Hoogle 5 working --- Handler/Hoogle.hs | 116 ++++++++++++++++---------------------- Stackage/Database/Cron.hs | 110 +++++++++++------------------------- stack.yaml | 2 +- templates/hoogle.hamlet | 63 ++++++++++----------- 4 files changed, 113 insertions(+), 178 deletions(-) diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index b73ec57..e433f74 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE QuasiQuotes #-} module Handler.Hoogle where import Control.DeepSeq (NFData(..)) import Control.DeepSeq.Generics (genericRnf) -import Control.Spoon (spoon) -import Data.Data (Data (..)) +import Data.Data (Data) import Data.Text.Read (decimal) import qualified Hoogle import Import import Text.Blaze.Html (preEscapedToHtml) import Stackage.Database import qualified Stackage.Database.Cron as Cron +import qualified Data.Text as T getHoogleDB :: SnapName -> Handler (Maybe FilePath) getHoogleDB name = do @@ -21,7 +22,7 @@ getHoogleR name = do Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return mquery <- lookupGetParam "q" mpage <- lookupGetParam "page" - exact <- maybe False (const True) <$> lookupGetParam "exact" + exact <- isJust <$> lookupGetParam "exact" -- FIXME remove, Hoogle no longer supports mresults' <- lookupGetParam "results" let count' = case decimal <$> mresults' of @@ -33,25 +34,30 @@ getHoogleR name = do _ -> 1 offset = (page - 1) * perPage mdatabasePath <- getHoogleDB name - heDatabase <- case mdatabasePath of - Just x -> return $ liftIO $ Hoogle.loadDatabase x - Nothing -> hoogleDatabaseNotAvailableFor name + dbPath <- maybe (hoogleDatabaseNotAvailableFor name) return mdatabasePath -- Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 lock <- appHoogleLock <$> getYesod - mresults <- case mquery of - Just query -> withMVar lock $ const $ runHoogleQuery heDatabase HoogleQueryInput - { hqiQueryInput = query - , hqiExactSearch = if exact then Just query else Nothing - , hqiLimitTo = count' - , hqiOffsetBy = offset - } - Nothing -> return $ HoogleQueryOutput "" [] Nothing + HoogleQueryOutput results mtotalCount <- + case mquery of + Just query -> do + let input = HoogleQueryInput + { hqiQueryInput = query + , hqiLimitTo = count' + , hqiOffsetBy = offset + } + + liftIO $ withMVar lock + $ const + $ Hoogle.withDatabase dbPath + -- NB! I got a segfault when I didn't force with $! + $ \db -> return $! runHoogleQuery db input + Nothing -> return $ HoogleQueryOutput [] Nothing let queryText = fromMaybe "" mquery pageLink p = (SnapshotR name HoogleR , (if exact then (("exact", "true"):) else id) - $ (maybe id (\q' -> (("q", q'):)) mquery) + $ maybe id (\q' -> (("q", q'):)) mquery [("page", tshow p)]) snapshotLink = SnapshotR name StackageHomeR hoogleForm = $(widgetFile "hoogle-form") @@ -84,15 +90,14 @@ perPage = 10 data HoogleQueryInput = HoogleQueryInput { hqiQueryInput :: Text - , hqiExactSearch :: Maybe Text , hqiLimitTo :: Int , hqiOffsetBy :: Int } deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) -data HoogleQueryOutput = HoogleQueryBad Text - | HoogleQueryOutput Text [HoogleResult] (Maybe Int) -- ^ Text == HTML version of query, Int == total count - deriving (Read, Typeable, Data, Show, Eq) +data HoogleQueryOutput = HoogleQueryOutput [HoogleResult] (Maybe Int) -- ^ Int == total count + deriving (Read, Typeable, Data, Show, Eq, Generic) +instance NFData HoogleQueryOutput data HoogleResult = HoogleResult { hrURL :: String @@ -118,56 +123,33 @@ instance NFData HoogleResult where rnf = genericRnf instance NFData PackageLink where rnf = genericRnf instance NFData ModuleLink where rnf = genericRnf -runHoogleQuery :: Monad m - => m Hoogle.Database - -> HoogleQueryInput - -> m HoogleQueryOutput -runHoogleQuery heDatabase HoogleQueryInput {..} = - runQuery $ Hoogle.parseQuery Hoogle.Haskell query +runHoogleQuery :: Hoogle.Database -> HoogleQueryInput -> HoogleQueryOutput +runHoogleQuery hoogledb HoogleQueryInput {..} = + HoogleQueryOutput targets mcount where + allTargets = Hoogle.searchDatabase hoogledb query + targets = take (min 100 hqiLimitTo) + $ drop hqiOffsetBy + $ map fixResult allTargets query = unpack hqiQueryInput - runQuery (Left err) = return $ HoogleQueryBad (tshow err) - runQuery (Right query') = do - hoogledb <- heDatabase - let query'' = Hoogle.queryExact classifier query' - rawRes = concatMap fixResult - $ Hoogle.search hoogledb query'' - mres = spoon - $ take (min 100 hqiLimitTo) - $ drop hqiOffsetBy rawRes - mcount = spoon $ limitedLength 0 rawRes - limitedLength x [] = Just x - limitedLength x (_:rest) - | x >= 20 = Nothing - | otherwise = limitedLength (x + 1) rest - rendered = pack $ Hoogle.showTagHTML $ Hoogle.renderQuery query'' - return $ case (,) <$> mres <*> mcount of - Nothing -> - HoogleQueryOutput rendered [] (Just 0) - Just (results, mcount') -> - HoogleQueryOutput rendered (take hqiLimitTo results) mcount' + mcount = limitedLength 0 allTargets - classifier = maybe Nothing - (const (Just Hoogle.UnclassifiedItem)) - hqiExactSearch + limitedLength x [] = Just x + limitedLength x (_:rest) + | x >= 20 = Nothing + | otherwise = limitedLength (x + 1) rest - fixResult (_, Hoogle.Result locs self docs) = do - (loc, _) <- take 1 locs - let sources' = unionsWith (++) $ - mapMaybe (getPkgModPair . snd) locs - return HoogleResult - { hrURL = loc - , hrSources = mapToList sources' - , hrTitle = Hoogle.showTagHTML self - , hrBody = fromMaybe "Problem loading documentation" $ - spoon $ Hoogle.showTagText docs - } - - getPkgModPair :: [(String, String)] - -> Maybe (Map PackageLink [ModuleLink]) - getPkgModPair [(pkg, pkgname), (modu, moduname)] = do - let pkg' = PackageLink pkgname pkg - modu' = ModuleLink moduname modu - return $ asMap $ singletonMap pkg' [modu'] - getPkgModPair _ = Nothing + 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]) + , hrTitle = -- FIXME find out why these replaces are necessary + unpack $ T.replace "<0>" "" $ T.replace "" "" $ pack + targetItem + , hrBody = targetDocs + } diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 80fdf66..65d8569 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -7,16 +7,13 @@ module Stackage.Database.Cron import ClassyPrelude.Conduit import Stackage.PackageIndex.Conduit import Database.Persist (Entity (Entity)) -import Data.Char (isAlpha) import qualified Codec.Archive.Tar as Tar import Stackage.Database import Network.HTTP.Client import Network.HTTP.Client.Conduit (bodyReaderSource) -import Filesystem (rename, removeTree, removeFile) +import Filesystem (rename, removeTree, removeFile, isFile, createTree) import Web.PathPieces (toPathPiece) -import Filesystem (isFile, createTree) import Filesystem.Path.CurrentOS (parent, fromText, encodeString) -import Control.Monad.State.Strict (StateT, get, put) import Network.HTTP.Types (status200) import Data.Streaming.Network (bindPortTCP) import Network.AWS (Credentials (Discover), @@ -35,6 +32,7 @@ import Data.Conduit.Zlib (WindowBits (WindowBits), compress, ungzip) import qualified Hoogle import System.Directory (doesFileExist) +import System.IO.Temp (withSystemTempDirectory) filename' :: Text filename' = concat @@ -208,6 +206,7 @@ stackageServerCron = do createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath) createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do + putStrLn $ "Creating Hoogle DB for " ++ toPathPiece name req' <- parseUrl $ unpack tarUrl let req = req' { decompress = const True } @@ -222,16 +221,27 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do void $ tryIO $ removeFile (fromString outname) createTree (fromString bindir) - dbs <- runResourceT - $ sourceTarFile False tarFP - $$ evalStateC 1 (mapMC (singleDB db name bindir)) - =$ sinkList + withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \_tmpdir -> do + let tmpdir = "/Users/michael/Desktop/hoo" + runResourceT + $ sourceTarFile False tarFP + $$ mapM_C (liftIO . singleDB db name tmpdir) - putStrLn "Merging databases..." - Hoogle.mergeDatabase (catMaybes dbs) outname - putStrLn "Merge done" + let args = + [ "generate" + , "--database=" ++ outname + , "--local=" ++ tmpdir + ] + putStrLn $ concat + [ "Merging databases... (" + , tshow args + , ")" + ] + Hoogle.hoogle args - return $ Just outname + putStrLn "Merge done" + + return $ Just outname where root = "hoogle-gen" bindir = root "bindir" @@ -243,81 +253,29 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do singleDB :: StackageDatabase -> SnapName - -> FilePath -- ^ bindir to write to + -> FilePath -- ^ temp directory to write .txt files to -> Tar.Entry - -> StateT Int (ResourceT IO) (Maybe FilePath) -singleDB db sname bindir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do - idx <- get - put $! idx + 1 - putStrLn $ "Loading file for Hoogle: " ++ pack (Tar.entryPath e) + -> IO () +singleDB db sname tmpdir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do + --putStrLn $ "Loading file for Hoogle: " ++ pack (Tar.entryPath e) let pkg = pack $ takeWhile (/= '.') $ Tar.entryPath e msp <- flip runReaderT db $ do Just (Entity sid _) <- lookupSnapshot sname lookupSnapshotPackage sid pkg case msp of - Nothing -> do - putStrLn $ "Unknown: " ++ pkg - return Nothing - Just (Entity _ sp) -> do - let ver = snapshotPackageVersion sp - pkgver = concat [pkg, "-", ver] - out = bindir show idx <.> "hoo" - src' = unlines - $ haddockHacks (Just $ unpack docsUrl) - $ lines - $ unpack - $ decodeUtf8 lbs + Nothing -> putStrLn $ "Unknown: " ++ pkg + Just _ -> do + let out = tmpdir unpack pkg <.> "txt" + -- FIXME add @url directive + writeFile out lbs + {- docsUrl = concat [ "https://www.stackage.org/haddock/" , toPathPiece sname , "/" , pkgver , "/index.html" - ] + ] -} - _errs <- liftIO $ Hoogle.createDatabase "" Hoogle.Haskell [] src' out - - return $ Just out -singleDB _ _ _ _ = return Nothing - ---------------------------------------------------------------------- --- HADDOCK HACKS --- (Copied from hoogle-4.2.36/src/Recipe/Haddock.hs) --- Modifications: --- 1) Some name qualification --- 2) Explicit type sig due to polymorphic elem --- 3) Fixed an unused binding warning - --- Eliminate @version --- Change :*: to (:*:), Haddock bug --- Change !!Int to !Int, Haddock bug --- Change instance [overlap ok] to instance, Haddock bug --- Change instance [incoherent] to instance, Haddock bug --- Change instance [safe] to instance, Haddock bug --- Change !Int to Int, HSE bug --- Drop {-# UNPACK #-}, Haddock bug --- Drop everything after where, Haddock bug - -haddockHacks :: Maybe Hoogle.URL -> [String] -> [String] -haddockHacks loc src = maybe id haddockPackageUrl loc (translate src) - where - translate :: [String] -> [String] - translate = map (unwords . g . map f . words) . filter (not . isPrefixOf "@version ") - - f "::" = "::" - f (':':xs) = "(:" ++ xs ++ ")" - f ('!':'!':x:xs) | isAlpha x = xs - f ('!':x:xs) | isAlpha x || x `elem` ("[(" :: String) = x:xs - f x | x `elem` ["[overlap","ok]","[incoherent]","[safe]"] = "" - f x | x `elem` ["{-#","UNPACK","#-}"] = "" - f x = x - - g ("where":_) = [] - g (x:xs) = x : g xs - g [] = [] - -haddockPackageUrl :: Hoogle.URL -> [String] -> [String] -haddockPackageUrl x = concatMap f - where f y | "@package " `isPrefixOf` y = ["@url " ++ x, y] - | otherwise = [y] +singleDB _ _ _ _ = return () diff --git a/stack.yaml b/stack.yaml index faff7b3..8bca575 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ packages: - . - location: git: https://github.com/ndmitchell/hoogle.git - commit: 779e04ed20a556bbb92789815ea60068fe188891 + commit: ca42c4ce3af1c1ae7d413de242063ca1f682d3ff extra-dep: true image: container: diff --git a/templates/hoogle.hamlet b/templates/hoogle.hamlet index 4194160..f166782 100644 --- a/templates/hoogle.hamlet +++ b/templates/hoogle.hamlet @@ -3,37 +3,32 @@

Hoogle Search

Within #{snapshotTitle snapshot} ^{hoogleForm} - $case mresults - $of HoogleQueryBad err -

#{err} -

For information on what queries should look like, see the hoogle user manual. - $of HoogleQueryOutput _query results mtotalCount - $if null results -

Your search produced no results. - $else -

    - $forall HoogleResult url sources self docs <- results -
  1. -

    - #{preEscapedToHtml self} - - $forall (pkg, modus) <- sources - -
    - #{plName pkg} - - $forall ModuleLink name url' <- modus - #{name} - $if null docs -

    No documentation available. - $else -

    #{docs} -

    - $with mpageCount <- fmap getPageCount mtotalCount - Page #{page} of #{maybe "many" show mpageCount} # - $if page > 1 - | - Previous - $if maybe True ((<) page) mpageCount - | - Next + $if null results +

    Your search produced no results. + $else +

      + $forall HoogleResult url sources self docs <- results +
    1. +

      + #{preEscapedToHtml self} + + $forall (pkg, modus) <- sources + +
      + #{plName pkg} + + $forall ModuleLink name url' <- modus + #{name} + $if null docs +

      No documentation available. + $else +

      #{docs} +

      + $with mpageCount <- fmap getPageCount mtotalCount + Page #{page} of #{maybe "many" show mpageCount} # + $if page > 1 + | + Previous + $if maybe True ((<) page) mpageCount + | + Next From 9b299e870eb48f2a099bb7a461cb5d1fbfe9c4a9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Jun 2016 20:31:34 +0300 Subject: [PATCH 03/12] Avoid double-escaping docs --- templates/hoogle.hamlet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/hoogle.hamlet b/templates/hoogle.hamlet index f166782..1d87a61 100644 --- a/templates/hoogle.hamlet +++ b/templates/hoogle.hamlet @@ -22,7 +22,7 @@ $if null docs

      No documentation available. $else -

      #{docs} +

      #{preEscapedToHtml docs}

      $with mpageCount <- fmap getPageCount mtotalCount Page #{page} of #{maybe "many" show mpageCount} # From a708c630ae9ba4920c8b69010bf9c76ce51763e7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 5 Jun 2016 12:36:09 +0300 Subject: [PATCH 04/12] Add back exact support --- Handler/Hoogle.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index e433f74..f9dc00c 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -22,7 +22,7 @@ getHoogleR name = do Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return mquery <- lookupGetParam "q" mpage <- lookupGetParam "page" - exact <- isJust <$> lookupGetParam "exact" -- FIXME remove, Hoogle no longer supports + exact <- isJust <$> lookupGetParam "exact" mresults' <- lookupGetParam "results" let count' = case decimal <$> mresults' of @@ -46,6 +46,7 @@ getHoogleR name = do { hqiQueryInput = query , hqiLimitTo = count' , hqiOffsetBy = offset + , hqiExact = exact } liftIO $ withMVar lock @@ -92,6 +93,7 @@ data HoogleQueryInput = HoogleQueryInput { hqiQueryInput :: Text , hqiLimitTo :: Int , hqiOffsetBy :: Int + , hqiExact :: Bool } deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) @@ -131,7 +133,7 @@ runHoogleQuery hoogledb HoogleQueryInput {..} = targets = take (min 100 hqiLimitTo) $ drop hqiOffsetBy $ map fixResult allTargets - query = unpack hqiQueryInput + query = unpack $ hqiQueryInput ++ if hqiExact then " is:exact" else "" mcount = limitedLength 0 allTargets From 4107980263f5adc38c715bc071a079ef128a0fd0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Jun 2016 17:42:33 +0300 Subject: [PATCH 05/12] More consistency in instances --- Handler/Hoogle.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index f9dc00c..ad7dd7a 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -99,7 +99,7 @@ data HoogleQueryInput = HoogleQueryInput data HoogleQueryOutput = HoogleQueryOutput [HoogleResult] (Maybe Int) -- ^ Int == total count deriving (Read, Typeable, Data, Show, Eq, Generic) -instance NFData HoogleQueryOutput +instance NFData HoogleQueryOutput where rnf = genericRnf data HoogleResult = HoogleResult { hrURL :: String From 34d23b6e47ed3d6ddf05c50bcc6be0949330bd8a Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 8 Jun 2016 14:19:46 +0200 Subject: [PATCH 06/12] Update DevelMain --- DevelMain.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/DevelMain.hs b/DevelMain.hs index ee71409..20fd934 100644 --- a/DevelMain.hs +++ b/DevelMain.hs @@ -16,13 +16,11 @@ import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp import Yesod -import Yesod.Static -- | Start the web server. main :: IO (Store (IORef Application)) main = - do s <- static "static" - c <- newChan + do c <- newChan (settings,app) <- getApplicationDev ref <- newIORef app tid <- forkIO @@ -46,7 +44,6 @@ update = do ref <- readStore store c <- readStore (Store 2) writeChan c () - s <- static "static" - (_settings,app) <- getApplicationDev + (_,app) <- getApplicationDev writeIORef ref app return store From e1f65cc65542371a50b8676d0c1ea8cb08e40632 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Jun 2016 15:53:55 +0300 Subject: [PATCH 07/12] Remove some accidentally added debug code (thanks @chrisdone) --- Stackage/Database/Cron.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 65d8569..b9fe4c0 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -221,8 +221,7 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do void $ tryIO $ removeFile (fromString outname) createTree (fromString bindir) - withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \_tmpdir -> do - let tmpdir = "/Users/michael/Desktop/hoo" + withSystemTempDirectory ("hoogle-" ++ unpack (toPathPiece name)) $ \tmpdir -> do runResourceT $ sourceTarFile False tarFP $$ mapM_C (liftIO . singleDB db name tmpdir) From 6eae9fb4198bedf3791bd77be28eaed63e8570bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Jun 2016 15:44:25 +0000 Subject: [PATCH 08/12] Include patch to Hoogle to avoid dependency on data files https://github.com/ndmitchell/hoogle/pull/169 --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 8bca575..ab5d85c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,8 @@ resolver: lts-5.15 packages: - . - location: - git: https://github.com/ndmitchell/hoogle.git - commit: ca42c4ce3af1c1ae7d413de242063ca1f682d3ff + git: https://github.com/snoyberg/hoogle.git + commit: 765bd653d687e8569cd989be1637de86dcb20d56 extra-dep: true image: container: From fffdf9717e4e3552dd85f1cae9542e6afb237fbd Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 14 Jun 2016 16:46:45 +0200 Subject: [PATCH 09/12] Add johan-tibell style to .dir-locals.el --- .dir-locals.el | 1 + 1 file changed, 1 insertion(+) diff --git a/.dir-locals.el b/.dir-locals.el index 1d5ee65..46667e3 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,4 +1,5 @@ ((haskell-mode . ((haskell-indent-spaces . 4) + (hindent-style . "johan-tibell") (haskell-process-type . cabal-repl) (haskell-process-use-ghci . t))) (hamlet-mode . ((hamlet/basic-offset . 4) From cb93e5472974a19eaecb9c580d1993004111294d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 14 Jun 2016 16:47:17 +0200 Subject: [PATCH 10/12] 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 From 9c52d4b6aa8e98f768126b2e869a669661393437 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 14 Jun 2016 16:50:12 +0200 Subject: [PATCH 11/12] Put back track call --- Handler/Haddock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 1f9910e..3774fef 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -117,6 +117,6 @@ nav = close = [EventEndElement name] getHaddockBackupR :: [Text] -> Handler () -getHaddockBackupR rest = redirect $ concat +getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat $ "https://s3.amazonaws.com/haddock.stackage.org" : map (cons '/') rest From 8db35e2f83bb3b9190feb9ce0486a14985d792ba Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 16 Jun 2016 15:06:26 +0200 Subject: [PATCH 12/12] Ignore non-present packages --- Handler/Haddock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 3774fef..716b6c8 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -83,7 +83,7 @@ redirectWithVersion slug rest = Entity sid _ <- lookupSnapshot slug >>= maybe notFound return mversion <- getPackageVersionBySnapshot sid pkg case mversion of - Nothing -> error "That package is not part of this snapshot." + Nothing -> return Nothing -- error "That package is not part of this snapshot." Just version -> do return (Just (HaddockR slug [pkg <> "-" <> version, file])) _ -> return Nothing