mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
Write hoogle DB generation errors to a file #47
This commit is contained in:
Michael Sloan
parent
b007d36631
commit
95c5835266
@ -19,7 +19,7 @@ import System.Process (createProcess, proc, cwd, waitForProcess)
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import Network.Mime (defaultMimeLookup)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import System.IO (IOMode (ReadMode), withBinaryFile, openBinaryFile)
|
||||
import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile, openBinaryFile)
|
||||
import Data.Conduit.Zlib (gzip)
|
||||
import System.Posix.Files (createLink)
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
@ -307,17 +307,19 @@ createHaddockUnpacker root store runDB' urlRenderRef = do
|
||||
ec <- waitForProcess ph
|
||||
if ec == ExitSuccess then return () else throwM ec
|
||||
|
||||
-- TODO: run hoogle and the database update in
|
||||
-- concurrent threads.
|
||||
|
||||
urlRender <- readIORef urlRenderRef
|
||||
runResourceT $ do
|
||||
liftIO $ createTree $ dirHoogleIdent dirs ident
|
||||
tmp <- liftIO getTemporaryDirectory
|
||||
(_releasekey, hoogletemp) <- allocate
|
||||
(fpFromString <$> createTempDirectory tmp "hoogle-database-gen")
|
||||
removeTree
|
||||
copyHoogleTextFiles destdir hoogletemp
|
||||
void $ resourceForkIO $ createHoogleDb dirs stackageEnt hoogletemp urlRender
|
||||
let logFp = fpToString (dirHoogleFp dirs ident ["error-log"])
|
||||
(_, errorLog) <- allocate (openBinaryFile logFp WriteMode) hClose
|
||||
copyHoogleTextFiles errorLog destdir hoogletemp
|
||||
-- TODO: Have hoogle requests block on this finishing.
|
||||
-- (Or display a "compiling DB" message to the user)
|
||||
void $ resourceForkIO $ createHoogleDb dirs stackageEnt errorLog hoogletemp urlRender
|
||||
|
||||
-- Determine which packages have documentation and update the
|
||||
-- database appropriately
|
||||
@ -396,68 +398,101 @@ getUploadDocMapR = do
|
||||
putUploadDocMapR :: Handler Html
|
||||
putUploadDocMapR = getUploadDocMapR
|
||||
|
||||
copyHoogleTextFiles :: FilePath -- ^ raw unpacked Haddock files
|
||||
copyHoogleTextFiles :: Handle -- ^ error log handle
|
||||
-> FilePath -- ^ raw unpacked Haddock files
|
||||
-> FilePath -- ^ temporary work directory
|
||||
-> ResourceT IO ()
|
||||
copyHoogleTextFiles raw tmp = do
|
||||
copyHoogleTextFiles errorLog raw tmp = do
|
||||
let tmptext = tmp </> "text"
|
||||
liftIO $ createTree tmptext
|
||||
sourceDirectory raw $$ mapM_C (\fp ->
|
||||
forM_ (nameAndVersionFromPath fp) $ \(name, version) -> do
|
||||
let src = fp </> fpFromText name <.> "txt"
|
||||
dst = tmptext </> fpFromText (name ++ "-" ++ version)
|
||||
whenM (liftIO $ isFile src) $
|
||||
sourceFile src $$ (sinkFile dst :: Sink ByteString (ResourceT IO) ())
|
||||
exists <- liftIO $ isFile src
|
||||
if exists
|
||||
then sourceFile src $$ (sinkFile dst :: Sink ByteString (ResourceT IO) ())
|
||||
else liftIO $ appendHoogleErrors errorLog $ HoogleErrors
|
||||
{ packageName = name
|
||||
, packageVersion = version
|
||||
, errors = ["No textual Hoogle DB (use \"cabal haddock --hoogle\")"]
|
||||
}
|
||||
)
|
||||
|
||||
createHoogleDb :: Dirs
|
||||
-> Entity Stackage
|
||||
-> Handle -- ^ error log handle
|
||||
-> FilePath -- ^ temp directory
|
||||
-> (Route App -> [(Text, Text)] -> Text)
|
||||
-> ResourceT IO ()
|
||||
createHoogleDb dirs (Entity _ stackage) tmpdir urlRender = do
|
||||
createHoogleDb dirs (Entity _ stackage) errorLog tmpdir urlRender = do
|
||||
let ident = stackageIdent stackage
|
||||
tmpbin = tmpdir </> "binary"
|
||||
hoogleDir = dirHoogleIdent dirs ident
|
||||
liftIO $ do
|
||||
createTree hoogleDir
|
||||
createTree tmpbin
|
||||
-- Create hoogle binary databases for each package
|
||||
sourceDirectory (tmpdir </> "text") $$ mapM_C
|
||||
( \fp -> do
|
||||
(releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose
|
||||
forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do
|
||||
src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH
|
||||
let -- Preprocess the haddock-generated manifest file.
|
||||
src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src
|
||||
docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) []
|
||||
urlPieces = [name <> "-" <> version, "index.html"]
|
||||
-- Compute the filepath of the resulting hoogle
|
||||
-- database.
|
||||
out = fpToString $ tmpbin </> base <.> "hoo"
|
||||
base = F.dropExtension $ filename fp
|
||||
errs <- Hoogle.createDatabase "foo" Hoogle.Haskell [] src' out
|
||||
-- TODO: handle these more gracefully?
|
||||
when (not $ null errs) $ putStrLn $ concat
|
||||
[ fpToText base
|
||||
, " Hoogle errors: "
|
||||
, tshow errs
|
||||
]
|
||||
release releaseKey
|
||||
)
|
||||
-- Merge the individual binary databases into one big database.
|
||||
liftIO $ do
|
||||
dbs <- listDirectory tmpbin
|
||||
let merged = hoogleDir </> "default.hoo"
|
||||
Hoogle.mergeDatabase
|
||||
(map fpToString (filter (/= merged) dbs))
|
||||
(fpToString merged)
|
||||
liftIO $ createTree tmpbin
|
||||
eres <- tryAny $ do
|
||||
-- Create hoogle binary databases for each package.
|
||||
sourceDirectory (tmpdir </> "text") $$ mapM_C
|
||||
( \fp -> do
|
||||
(releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose
|
||||
forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do
|
||||
src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH
|
||||
let -- Preprocess the haddock-generated manifest file.
|
||||
src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src
|
||||
docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) []
|
||||
urlPieces = [name <> "-" <> version, "index.html"]
|
||||
-- Compute the filepath of the resulting hoogle
|
||||
-- database.
|
||||
out = fpToString $ tmpbin </> fpFromText base
|
||||
base = name <> "-" <> version <> ".hoo"
|
||||
errs <- Hoogle.createDatabase "" Hoogle.Haskell [] src' out
|
||||
when (not $ null errs) $ do
|
||||
-- TODO: remove this printing once errors are yielded
|
||||
-- to the user.
|
||||
putStrLn $ concat
|
||||
[ base
|
||||
, " Hoogle errors: "
|
||||
, tshow errs
|
||||
]
|
||||
appendHoogleErrors errorLog $ HoogleErrors
|
||||
{ packageName = name
|
||||
, packageVersion = version
|
||||
, errors = map show errs
|
||||
}
|
||||
release releaseKey
|
||||
)
|
||||
-- Merge the individual binary databases into one big database.
|
||||
liftIO $ do
|
||||
dbs <- listDirectory tmpbin
|
||||
Hoogle.mergeDatabase
|
||||
(map fpToString dbs)
|
||||
(fpToString (dirHoogleFp dirs ident ["default.hoo"]))
|
||||
case eres of
|
||||
Right () -> return ()
|
||||
Left err -> liftIO $ appendHoogleErrors errorLog $ HoogleErrors
|
||||
{ packageName = "Exception thrown while building hoogle DB"
|
||||
, packageVersion = ""
|
||||
, errors = [show err]
|
||||
}
|
||||
|
||||
data HoogleErrors = HoogleErrors
|
||||
{ packageName :: Text
|
||||
, packageVersion :: Text
|
||||
, errors :: [String]
|
||||
} deriving (Generic)
|
||||
|
||||
instance ToJSON HoogleErrors where
|
||||
instance FromJSON HoogleErrors where
|
||||
|
||||
-- Appends hoogle errors to a log file. By encoding within a single
|
||||
-- list, the resulting file can be decoded as [HoogleErrors].
|
||||
appendHoogleErrors :: Handle -> HoogleErrors -> IO ()
|
||||
appendHoogleErrors h errs = hPut h (Y.encode [errs])
|
||||
|
||||
nameAndVersionFromPath :: FilePath -> Maybe (Text, Text)
|
||||
nameAndVersionFromPath fp =
|
||||
(\name -> (name, version)) <$> stripSuffix "-" name'
|
||||
where
|
||||
(name', version) = T.breakOnEnd "-" $ fpToText $ filename fp
|
||||
(name', version) = T.breakOnEnd "-" $ fpToText $ F.dropExtension $ filename fp
|
||||
|
||||
---------------------------------------------------------------------
|
||||
-- HADDOCK HACKS
|
||||
|
||||
Loading…
Reference in New Issue
Block a user