Module listing page
This commit is contained in:
Michael Snoyman
parent
e71b8c036b
commit
50ff9efead
3 changed files with 79 additions and 84 deletions
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
(#{package}-#{version})
|
||||
<a href=#{mliUrl mli}>#{mliName mli}
|
||||
(#{mliPackageVersion mli})
|
||||
|
|
|
|||
Loading…
Reference in a new issue