Write hoogle DB generation errors to a file #47

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
+                    let logFp = fpToString (dirHoogleFp dirs ident ["error-log"])
-                    void $ resourceForkIO $ createHoogleDb dirs stackageEnt hoogletemp urlRender
+                    (_, 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) $
+            exists <- liftIO $ isFile src
-                sourceFile src $$ (sinkFile dst :: Sink ByteString (ResourceT IO) ())
+            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 $ createTree tmpbin
-    liftIO $ do
+    eres <- tryAny $ do
-        createTree hoogleDir
+        -- Create hoogle binary databases for each package.
-        createTree tmpbin
+        sourceDirectory (tmpdir </> "text") $$ mapM_C
-    -- Create hoogle binary databases for each package
+          ( \fp -> do
-    sourceDirectory (tmpdir </> "text") $$ mapM_C
+            (releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose
-      ( \fp -> do
+            forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do
-        (releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose
+                src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH
-        forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do
+                let -- Preprocess the haddock-generated manifest file.
-            src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH
+                    src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src
-            let -- Preprocess the haddock-generated manifest file.
+                    docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) []
-                src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src
+                    urlPieces = [name <> "-" <> version, "index.html"]
-                docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) []
+                    -- Compute the filepath of the resulting hoogle
-                urlPieces = [name <> "-" <> version, "index.html"]
+                    -- database.
-                -- Compute the filepath of the resulting hoogle
+                    out = fpToString $ tmpbin </> fpFromText base
-                -- database.
+                    base = name <> "-" <> version <> ".hoo"
-                out = fpToString $ tmpbin </> base <.> "hoo"
+                errs <- Hoogle.createDatabase "" Hoogle.Haskell [] src' out
-                base = F.dropExtension $ filename fp
+                when (not $ null errs) $ do
-            errs <- Hoogle.createDatabase "foo" Hoogle.Haskell [] src' out
+                    -- TODO: remove this printing once errors are yielded
-            -- TODO: handle these more gracefully?
+                    -- to the user.
-            when (not $ null errs) $ putStrLn $ concat
+                    putStrLn $ concat
-                [ fpToText base
+                        [ base
-                , " Hoogle errors: "
+                        , " Hoogle errors: "
-                , tshow errs
+                        , tshow errs
-                ]
+                        ]
-        release releaseKey
+                    appendHoogleErrors errorLog $ HoogleErrors
-        )
+                        { packageName = name
-    -- Merge the individual binary databases into one big database.
+                        , packageVersion = version
-    liftIO $ do
+                        , errors = map show errs
-        dbs <- listDirectory tmpbin
+                        }
-        let merged = hoogleDir </> "default.hoo"
+            release releaseKey
-        Hoogle.mergeDatabase
+            )
-            (map fpToString (filter (/= merged) dbs))
+        -- Merge the individual binary databases into one big database.
-            (fpToString merged)
+        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