diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index 123b3cd..dc73bbd 100644 --- a/Handler/StackageHome.hs +++ b/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 slug = do - 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") - -} +getSnapshotPackagesR :: SnapName -> Handler () -- FIXME move to OldLinks? +getSnapshotPackagesR name = redirect $ SnapshotR name StackageHomeR getDocsR :: SnapName -> Handler Html -getDocsR slug = do - error "getDocsR" - {- - Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug +getDocsR name = do + Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return + mlis <- getSnapshotModules sid + 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 - cachedWidget (20 * 60) ("module-list-" ++ toPathPiece slug) $ do - 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") - -} + setTitle $ toHtml $ "Module list for " ++ toPathPiece name + $(widgetFile "doc-list") diff --git a/Stackage/Database.hs b/Stackage/Database.hs index dc8d134..c954bb0 100644 --- a/Stackage/Database.hs +++ b/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) - go _ = return Nothing + return $ Just (name, wrapper bp) + 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 (name, bp) = do +addPlan :: (SnapName, Either BuildPlan DocMap) -> SqlPersistT (ResourceT IO) () +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] + } diff --git a/templates/doc-list.hamlet b/templates/doc-list.hamlet index 8ea7c84..fa92c44 100644 --- a/templates/doc-list.hamlet +++ b/templates/doc-list.hamlet @@ -1,9 +1,9 @@
-

Module listing for #{toPathPiece slug} +

Module listing for #{toPathPiece name}

- Return to snapshot + Return to snapshot