Module listing page

Handler/StackageHome.hs

@@ -105,77 +105,20 @@ getStackageCabalConfigR name = do
 yearMonthDay :: FormatTime t => t -> String
 yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
 
-getSnapshotPackagesR :: SnapName -> Handler Html
+getSnapshotPackagesR :: SnapName -> Handler () -- FIXME move to OldLinks?
-getSnapshotPackagesR slug = do
+getSnapshotPackagesR name = redirect $ SnapshotR name StackageHomeR
-    error "getSnapshotPackagesR"
-    {-
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
-    defaultLayout $ do
-        setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
-        cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(m,p) -> do
-                E.where_ $
-                    (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
-                    (p E.^. PackageStackage E.==. E.val sid)
-                E.orderBy [E.asc $ m E.^. MetadataName]
-                E.groupBy ( m E.^. MetadataName
-                          , m E.^. MetadataSynopsis
-                          )
-                return
-                    ( m E.^. MetadataName
-                    , m E.^. MetadataSynopsis
-                    , E.max_ $ E.case_
-                        [ ( p E.^. PackageHasHaddocks
-                          , p E.^. PackageVersion
-                          )
-                        ]
-                        (E.val (Version ""))
-                    )
-            let packages = flip map packages' $ \(name, syn, forceNotNull -> mversion) ->
-                    ( E.unValue name
-                    , mversion
-                    , strip $ E.unValue syn
-                    , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
-                        [ toPathPiece $ E.unValue name
-                        , "-"
-                        , version
-                        ]
-                    )
-                forceNotNull (E.Value Nothing) = Nothing
-                forceNotNull (E.Value (Just (Version v)))
-                    | null v = Nothing
-                    | otherwise = Just v
-            $(widgetFile "package-list")
-  where strip x = fromMaybe x (stripSuffix "." x)
-        mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot")
-    -}
 
 getDocsR :: SnapName -> Handler Html
-getDocsR slug = do
+getDocsR name = do
-    error "getDocsR"
+    Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
-    {-
+    mlis <- getSnapshotModules sid
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+    render <- getUrlRender
+    let mliUrl mli = render $ HaddockR name
+            [ mliPackageVersion mli
+            , omap toDash (mliName mli) ++ ".html"
+            ]
+        toDash '.' = '-'
+        toDash c = c
     defaultLayout $ do
-        setTitle $ toHtml $ "Module list for " ++ toPathPiece slug
+        setTitle $ toHtml $ "Module list for " ++ toPathPiece name
-        cachedWidget (20 * 60) ("module-list-" ++ toPathPiece slug) $ do
+        $(widgetFile "doc-list")
-            modules' <- handlerToWidget $ runDB $ E.select $ E.from $ \(d,m) -> do
-                E.where_ $
-                    (d E.^. DocsSnapshot E.==. E.val (Just sid)) E.&&.
-                    (d E.^. DocsId E.==. m E.^. ModuleDocs)
-                E.orderBy [ E.asc $ m E.^. ModuleName
-                          , E.asc $ d E.^. DocsName
-                          ]
-                return
-                    ( m E.^. ModuleName
-                    , m E.^. ModuleUrl
-                    , d E.^. DocsName
-                    , d E.^. DocsVersion
-                    )
-            let modules = flip map modules' $ \(name, url, package, version) ->
-                    ( E.unValue name
-                    , E.unValue url
-                    , E.unValue package
-                    , E.unValue version
-                    )
-            $(widgetFile "doc-list")
-            -}

Stackage/Database.hs

@@ -12,8 +12,11 @@ module Stackage.Database
     , getPackages
     , createStackageDatabase
     , openStackageDatabase
+    , ModuleListingInfo (..)
+    , getSnapshotModules
     ) where
 
+import Web.PathPieces (toPathPiece)
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
 import Text.Markdown (Markdown (..))
@@ -71,6 +74,10 @@ SnapshotPackage
     isCore Bool
     version Text
     UniqueSnapshotPackage snapshot package
+Module
+    package SnapshotPackageId
+    name Text
+    UniqueModule package name
 Dep
     user PackageId
     usedBy PackageId
@@ -99,16 +106,19 @@ sourcePackages root = do
             liftIO $ runIn dir "git" ["archive", "--output", fp, "--format", "tar", "master"]
             sourceTarFile False fp
 
-sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, BuildPlan)
+sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, Either BuildPlan DocMap)
 sourceBuildPlans root = do
     forM_ ["lts-haskell", "stackage-nightly"] $ \dir -> do
         dir <- liftIO $ cloneOrUpdate root "fpco" dir
-        sourceDirectory dir =$= concatMapMC go
+        sourceDirectory dir =$= concatMapMC (go Left)
+        let docdir = dir </> "docs"
+        whenM (liftIO $ F.isDirectory docdir) $
+            sourceDirectory docdir =$= concatMapMC (go Right)
   where
-    go fp | Just name <- nameFromFP fp = liftIO $ do
+    go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
         bp <- decodeFileEither (fpToString fp) >>= either throwM return
-        return $ Just (name, bp)
+        return $ Just (name, wrapper bp)
-    go _ = return Nothing
+    go _ _ = return Nothing
 
     nameFromFP fp = do
         base <- stripSuffix ".yaml" $ fpToText $ filename fp
@@ -141,6 +151,7 @@ createStackageDatabase :: MonadIO m => FilePath -> m ()
 createStackageDatabase fp = liftIO $ do
     void $ tryIO $ removeFile $ fpToString fp
     StackageDatabase pool <- openStackageDatabase fp
+    putStrLn "Initial migration"
     runSqlPool (runMigration migrateAll) pool
     root <- liftIO $ fmap (</> "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage"
     F.createTree root
@@ -198,8 +209,9 @@ addPackage e =
     renderContent txt "haddock" = renderHaddock txt
     renderContent txt _ = toHtml $ Textarea txt
 
-addPlan :: (SnapName, BuildPlan) -> SqlPersistT (ResourceT IO) ()
+addPlan :: (SnapName, Either BuildPlan DocMap) -> SqlPersistT (ResourceT IO) ()
-addPlan (name, bp) = do
+addPlan (name, Left bp) = do
+    putStrLn $ "Adding build plan: " ++ toPathPiece name
     sid <- insert Snapshot
         { snapshotName = name
         , snapshotGhc = display $ siGhcVersion $ bpSystemInfo bp
@@ -231,7 +243,17 @@ addPlan (name, bp) = do
     allPackages = mapToList
         $ fmap (, True) (siCorePackages $ bpSystemInfo bp)
        ++ fmap ((, False) . ppVersion) (bpPackages bp)
-
+addPlan (name, Right dm) = do
+    [sid] <- selectKeysList [SnapshotName ==. name] []
+    putStrLn $ "Adding doc map: " ++ toPathPiece name
+    forM_ (mapToList dm) $ \(pkg, pd) -> do
+        [pid] <- selectKeysList [PackageName ==. pkg] []
+        [spid] <- selectKeysList [SnapshotPackageSnapshot ==. sid, SnapshotPackagePackage ==. pid] []
+        forM_ (mapToList $ pdModules pd) $ \(name, paths) ->
+            insert_ Module
+                { modulePackage = spid
+                , moduleName = name
+                }
 
 run :: GetStackageDatabase m => SqlPersistT IO a -> m a
 run inner = do
@@ -291,3 +313,33 @@ getPackages sid = liftM (map toPLI) $ run $ do
         , pliSynopsis = synopsis
         , pliIsCore = isCore
         }
+
+data ModuleListingInfo = ModuleListingInfo
+    { mliName :: !Text
+    , mliPackageVersion :: !Text
+    }
+
+getSnapshotModules
+    :: GetStackageDatabase m
+    => SnapshotId
+    -> m [ModuleListingInfo]
+getSnapshotModules sid = liftM (map toMLI) $ run $ do
+    E.select $ E.from $ \(p,sp,m) -> do
+        E.where_ $
+            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
+            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
+            (m E.^. ModulePackage E.==. sp E.^. SnapshotPackageId)
+        E.orderBy
+            [ E.asc $ m E.^. ModuleName
+            , E.asc $ p E.^. PackageName
+            ]
+        return
+            ( m E.^. ModuleName
+            , p E.^. PackageName
+            , sp E.^. SnapshotPackageVersion
+            )
+  where
+    toMLI (E.Value name, E.Value pkg, E.Value version) = ModuleListingInfo
+        { mliName = name
+        , mliPackageVersion = concat [pkg, "-", version]
+        }

templates/doc-list.hamlet

@@ -1,9 +1,9 @@
 <div .container>
-    <h1>Module listing for #{toPathPiece slug}
+    <h1>Module listing for #{toPathPiece name}
     <p>
-        <a href=@{SnapshotR slug StackageHomeR}>Return to snapshot
+        <a href=@{SnapshotR name StackageHomeR}>Return to snapshot
     <ul>
-        $forall (name, url, package, version) <- modules
+        $forall mli <- mlis
             <li>
-                <a href=#{url}>#{name}
+                <a href=#{mliUrl mli}>#{mliName mli}
-                (#{package}-#{version})
+                (#{mliPackageVersion mli})