From 6f4e9eb4fd1c61c3d6c58b33195dae045445c373 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 10 Dec 2014 11:12:53 +0200
Subject: [PATCH] Track whether an individual package has documentation #49

---
 Application.hs            |  1 +
 Handler/Haddock.hs        | 29 +++++++++++++++++++++++++++--
 Handler/StackageHome.hs   |  6 +++---
 Handler/UploadStackage.hs |  1 +
 config/models             |  1 +
 5 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/Application.hs b/Application.hs
index 3a5cdaa..c9b80b9 100644
--- a/Application.hs
+++ b/Application.hs
@@ -164,6 +164,7 @@ makeFoundation useEcho conf = do
 
     let haddockRootDir' = "/tmp/stackage-server-haddocks2"
     (statusRef, unpacker) <- createHaddockUnpacker haddockRootDir' blobStore'
+        (flip (Database.Persist.runPool dbconf) p)
     widgetCache' <- newIORef mempty
 
 #if MIN_VERSION_yesod_gitrepo(0,1,1)
diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs
index a8ef524..e1d769b 100644
--- a/Handler/Haddock.hs
+++ b/Handler/Haddock.hs
@@ -17,6 +17,7 @@ import Data.Byteable (toBytes)
 import Crypto.Hash (Digest, SHA1)
 import qualified Filesystem.Path.CurrentOS as F
 import Data.Slug (SnapSlug)
+import qualified Data.Text as T
 
 form :: Form FileInfo
 form = renderDivs $ areq fileField "tarball containing docs"
@@ -208,8 +209,10 @@ dirCacheFp dirs digest =
 -- demand.
 createHaddockUnpacker :: FilePath -- ^ haddock root
                       -> BlobStore StoreKey
+                      -> (forall a m. (MonadIO m, MonadBaseControl IO m)
+                            => SqlPersistT m a -> m a)
                       -> IO (IORef Text, ForceUnpack -> PackageSetIdent -> IO ())
-createHaddockUnpacker root store = do
+createHaddockUnpacker root store runDB' = do
     createTree $ dirCacheRoot dirs
     createTree $ dirRawRoot dirs
     createTree $ dirGzRoot dirs
@@ -256,9 +259,31 @@ createHaddockUnpacker root store = do
                         Just src -> src $$ sinkHandle temph
                 hClose temph
                 createTree $ dirRawIdent dirs ident
+                let destdir = dirRawIdent dirs ident
                 (Nothing, Nothing, Nothing, ph) <- createProcess
                     (proc "tar" ["xf", tempfp])
-                        { cwd = Just $ fpToString $ dirRawIdent dirs ident
+                        { cwd = Just $ fpToString destdir
                         }
                 ec <- waitForProcess ph
                 if ec == ExitSuccess then return () else throwM ec
+
+                -- Determine which packages have documentation and update the
+                -- database appropriately
+                runResourceT $ runDB' $ do
+                    ment <- getBy $ UniqueStackage ident
+                    forM_ ment $ \(Entity sid _) -> do
+                        updateWhere
+                            [PackageStackage ==. sid]
+                            [PackageHasHaddocks =. False]
+                        sourceDirectory destdir $$ mapM_C (\fp -> do
+                            let mname = stripSuffix "-"
+                                      $ fst
+                                      $ T.breakOnEnd "-"
+                                      $ fpToText
+                                      $ filename fp
+                            forM_ mname $ \name -> updateWhere
+                                [ PackageStackage ==. sid
+                                , PackageName' ==. PackageName name
+                                ]
+                                [PackageHasHaddocks =. True]
+                            )
diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs
index bc0dd20..d4628ef 100644
--- a/Handler/StackageHome.hs
+++ b/Handler/StackageHome.hs
@@ -45,7 +45,7 @@ getStackageMetadataR slug = do
             , Asc PackageVersion
             ] $= mapC (Chunk . toBuilder . showPackage)
 
-    showPackage (Entity _ (Package _ name version _)) = concat
+    showPackage (Entity _ (Package _ name version _ _)) = concat
         [ toPathPiece name
         , "-"
         , toPathPiece version
@@ -68,13 +68,13 @@ getStackageCabalConfigR slug = do
 
     goFirst = do
         mx <- await
-        forM_ mx $ \(Entity _ (Package _ name version _)) -> yield $ Chunk $
+        forM_ mx $ \(Entity _ (Package _ name version _ _)) -> yield $ Chunk $
             toBuilder (asText "constraints: ") ++
             toBuilder (toPathPiece name) ++
             toBuilder (asText " ==") ++
             toBuilder (toPathPiece version)
 
-    showPackage (Entity _ (Package _ name version _)) =
+    showPackage (Entity _ (Package _ name version _ _)) =
         toBuilder (asText ",\n             ") ++
         toBuilder (toPathPiece name) ++
         toBuilder (asText " ==") ++
diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs
index 0d0180f..ffbfc0c 100644
--- a/Handler/UploadStackage.hs
+++ b/Handler/UploadStackage.hs
@@ -143,6 +143,7 @@ putUploadStackageR = do
                                         , packageName' = name
                                         , packageVersion = version
                                         , packageOverwrite = overwrite
+                                        , packageHasHaddocks = False
                                         }
 
                                     setAlias
diff --git a/config/models b/config/models
index 0a8f918..2c8cbc8 100644
--- a/config/models
+++ b/config/models
@@ -42,6 +42,7 @@ Package
     stackage StackageId
     name' PackageName sql=name
     version Version
+    hasHaddocks Bool default=true
     overwrite Bool
 
 Tag