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)
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
diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs
index b0d81d0..716b6c8 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 -> return 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 = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat
$ "https://s3.amazonaws.com/haddock.stackage.org"
: map (cons '/') rest
diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs
index 4d9603f..600e330 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 = track "Handler.Hoogle.getHoogleDB" $ do
@@ -21,7 +22,7 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ 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"
mresults' <- lookupGetParam "results"
let count' =
case decimal <$> mresults' of
@@ -33,25 +34,32 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ 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
+ urlRender <- getUrlRender
+ HoogleQueryOutput results mtotalCount <-
+ case mquery of
+ Just query -> do
+ let input = HoogleQueryInput
+ { hqiQueryInput = query
+ , hqiLimitTo = count'
+ , hqiOffsetBy = offset
+ , hqiExact = exact
+ }
+
+ liftIO $ withMVar lock
+ $ const
+ $ Hoogle.withDatabase dbPath
+ -- NB! I got a segfault when I didn't force with $!
+ $ \db -> return $! runHoogleQuery urlRender name 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")
@@ -85,15 +93,15 @@ perPage = 10
data HoogleQueryInput = HoogleQueryInput
{ hqiQueryInput :: Text
- , hqiExactSearch :: Maybe Text
, hqiLimitTo :: Int
, hqiOffsetBy :: Int
+ , hqiExact :: Bool
}
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 where rnf = genericRnf
data HoogleResult = HoogleResult
{ hrURL :: String
@@ -119,57 +127,52 @@ instance NFData HoogleResult where rnf = genericRnf
instance NFData PackageLink where rnf = genericRnf
instance NFData ModuleLink where rnf = genericRnf
-runHoogleQuery :: MonadIO m
- => m Hoogle.Database
+runHoogleQuery :: (Route App -> Text)
+ -> SnapName
+ -> Hoogle.Database
-> HoogleQueryInput
- -> m HoogleQueryOutput
-runHoogleQuery heDatabase HoogleQueryInput {..} =
- track "Handler.Hoogle.runHoogleQuery" $
- runQuery $ Hoogle.parseQuery Hoogle.Haskell query
+ -> HoogleQueryOutput
+runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} =
+ HoogleQueryOutput targets mcount
where
- query = unpack hqiQueryInput
+ allTargets = Hoogle.searchDatabase hoogledb query
+ targets = take (min 100 hqiLimitTo)
+ $ drop hqiOffsetBy
+ $ map fixResult allTargets
+ query = unpack $ hqiQueryInput ++ if hqiExact then " is:exact" else ""
- 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
- }
+ fixResult Hoogle.Target {..} = HoogleResult
+ { 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
- 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
+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
diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs
index 80fdf66..b9fe4c0 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,26 @@ 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
+ 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 +252,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 15f9ed0..193c5b8 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,10 @@
resolver: lts-5.15
+packages:
+- .
+- location:
+ git: https://github.com/snoyberg/hoogle.git
+ commit: 765bd653d687e8569cd989be1637de86dcb20d56
+ extra-dep: true
image:
container:
name: fpco/stackage-server
diff --git a/stackage-server.cabal b/stackage-server.cabal
index 425a68c..bcc2b4f 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -161,7 +161,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
diff --git a/templates/hoogle.hamlet b/templates/hoogle.hamlet
index 4194160..1d87a61 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
- -
-
- #{preEscapedToHtml self}
-