From 95c583526665b0f45fbdffe9dc8b28caa3510824 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Fri, 2 Jan 2015 20:18:01 -0800 Subject: [PATCH] Write hoogle DB generation errors to a file #47 --- Handler/Haddock.hs | 127 +++++++++++++++++++++++++++++---------------- 1 file changed, 81 insertions(+), 46 deletions(-) diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 9144265..8884663 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -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