Track whether an individual package has documentation #49

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)

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]
+                            )

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 " ==") ++

Handler/UploadStackage.hs

@@ -143,6 +143,7 @@ putUploadStackageR = do
                                         , packageName' = name
                                         , packageVersion = version
                                         , packageOverwrite = overwrite
+                                        , packageHasHaddocks = False
                                         }
 
                                     setAlias

config/models

@@ -42,6 +42,7 @@ Package
     stackage StackageId
     name' PackageName sql=name
     version Version
+    hasHaddocks Bool default=true
     overwrite Bool
 
 Tag