Package pages

This commit is contained in:
Michael Snoyman 2015-05-13 14:08:58 +03:00
parent deac45e202
commit d77b87b6c2
6 changed files with 216 additions and 195 deletions

View File

@ -9,6 +9,7 @@ module Handler.Package
, postPackageUnlikeR
, postPackageTagR
, postPackageUntagR
, packagePage
) where
import Data.Char
@ -25,79 +26,65 @@ import Formatting
import Import
import qualified Text.Blaze.Html.Renderer.Text as LT
import Text.Email.Validate
import Stackage.Database
-- | Page metadata package.
getPackageR :: PackageName -> Handler Html
getPackageR pn =
error "getPackageR"
{-
packagePage pn Nothing (selectFirst [DocsName ==. pn] [Desc DocsUploaded])
getPackageR = packagePage Nothing
packagePage :: PackageName
-> Maybe Version
-> YesodDB App (Maybe (Entity Docs))
packagePage :: Maybe (SnapName, Version)
-> PackageName
-> Handler Html
packagePage pn mversion getDocs = do
let haddocksLink ident version =
HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
packagePage mversion pname = do
let pname' = toPathPiece pname
(deprecated, inFavourOf) <- getDeprecated pname'
latests <- getLatests pname'
render <- getUrlRender
muid <- maybeAuthId
(mnightly, mlts, nLikes, liked,
Entity _ metadata, revdeps', mdocs, deprecated, inFavourOf) <- runDB $ do
mnightly <- getNightly pn
mlts <- getLts pn
nLikes <- count [LikePackage ==. pn]
let getLiked uid = (>0) <$> count [LikePackage ==. pn, LikeVoter ==. uid]
(nLikes, liked) <- runDB $ do
nLikes <- count [LikePackage ==. pname]
let getLiked uid = (>0) <$> count [LikePackage ==. pname, LikeVoter ==. uid]
liked <- maybe (return False) getLiked muid
metadata <- getBy404 (UniqueMetadata pn)
revdeps' <- reverseDeps pn
mdocsent <- getDocs
mdocs <- forM mdocsent $ \(Entity docsid (Docs _ version _ _)) -> (,)
<$> pure version
<*> (map entityVal <$>
selectList [ModuleDocs ==. docsid] [Asc ModuleName])
deprecated <- getDeprecated pn
inFavourOf <- getInFavourOf pn
return ( mnightly
, mlts
, nLikes
, liked
, metadata
, revdeps'
, mdocs
, deprecated
, inFavourOf
)
return (nLikes, liked)
deps' <- getDeps pname'
revdeps' <- getRevDeps pname'
Entity _ package <- getPackage pname' >>= maybe notFound return
let mdocs :: Maybe (SnapName, Text, [Text])
mdocs = Nothing
{-
mdocs <- error "mdocs"
-}
let ixInFavourOf = zip [0::Int ..] inFavourOf
displayedVersion = fromMaybe (metadataVersion metadata) mversion
displayedVersion = maybe (packageLatest package) (toPathPiece . snd) mversion
myTags <- maybe (return []) (runDB . user'sTagsOf pn) muid
myTags <- maybe (return []) (runDB . user'sTagsOf pname) muid
tags <- fmap (map (\(v,count') -> (v,count',any (==v) myTags)))
(runDB (packageTags pn))
(runDB (packageTags pname))
let likeTitle = if liked
then "You liked this!"
else "I like this!" :: Text
let homepage = case T.strip (metadataHomepage metadata) of
let homepage = case T.strip (packageHomepage package) of
x | null x -> Nothing
| otherwise -> Just x
synopsis = metadataSynopsis metadata
deps = enumerate (metadataDeps metadata)
synopsis = packageSynopsis package
deps = enumerate deps'
revdeps = enumerate revdeps'
authors = enumerate (parseIdentitiesLiberally (metadataAuthor metadata))
maintainers = let ms = enumerate (parseIdentitiesLiberally (metadataMaintainer metadata))
authors = enumerate (parseIdentitiesLiberally (packageAuthor package))
maintainers = let ms = enumerate (parseIdentitiesLiberally (packageMaintainer package))
in if ms == authors
then []
else ms
defaultLayout $ do
setTitle $ toHtml pn
setTitle $ toHtml pname
$(combineStylesheets 'StaticR
[ css_font_awesome_min_css
])
let pn = pname
toPkgVer x y = concat [x, "-", y]
$(widgetFile "package")
where enumerate = zip [0::Int ..]
@ -127,60 +114,6 @@ user'sTagsOf pn uid =
E.orderBy [E.asc (t ^. TagTag)]
return (t ^. TagTag))))
-- | Get reverse dependencies of a package.
reverseDeps :: PackageName -> YesodDB App [PackageName]
reverseDeps pn = fmap (map boilerplate) $ E.select $ E.from $ \dep -> do
E.where_ $ dep ^. DependencyDep E.==. E.val pn
E.orderBy [E.asc $ dep ^. DependencyUser]
return $ dep ^. DependencyUser
where boilerplate (E.Value e) = e
-- | Get the latest nightly snapshot for the given package.
getNightly :: PackageName -> YesodDB App (Maybe (Day, Text, Version, SnapSlug))
getNightly pn =
fmap (fmap boilerplate . listToMaybe)
(E.select (E.from query))
where boilerplate (E.Value a,E.Value b,E.Value c,E.Value d) =
(a,b,c,d)
query (p,n,s) =
do E.where_ ((p ^. PackageName' E.==. E.val pn) E.&&.
(p ^. PackageStackage E.==. n ^. NightlyStackage) E.&&.
(s ^. StackageId E.==. n ^. NightlyStackage))
E.orderBy [E.desc (n ^. NightlyDay)]
return (n ^. NightlyDay
,n ^. NightlyGhcVersion
,p ^. PackageVersion
,s ^. StackageSlug)
-- | Get the latest LTS snapshot for the given package.
getLts :: PackageName -> YesodDB App (Maybe (Int,Int,Version,SnapSlug))
getLts pn =
fmap (fmap boilerplate . listToMaybe)
(E.select (E.from query))
where boilerplate (E.Value a,Value b,Value c,Value d) =
(a,b,c,d)
query (p,n,s) =
do E.where_ ((p ^. PackageName' E.==. E.val pn) E.&&.
(p ^. PackageStackage E.==. n ^. LtsStackage) E.&&.
(s ^. StackageId E.==. n ^. LtsStackage))
E.orderBy [E.desc (n ^. LtsMajor),E.desc (n ^. LtsMinor)]
return (n ^. LtsMajor
,n ^. LtsMinor
,p ^. PackageVersion
,s ^. StackageSlug)
getDeprecated :: PackageName -> YesodDB App Bool
getDeprecated pn = fmap ((>0) . length) $ E.select $ E.from $ \d -> do
E.where_ $ d ^. DeprecatedPackage E.==. E.val pn
return ()
getInFavourOf :: PackageName -> YesodDB App [PackageName]
getInFavourOf pn = fmap unBoilerplate $ E.select $ E.from $ \s -> do
E.where_ $ s ^. SuggestedInsteadOf E.==. E.val pn
return (s ^. SuggestedPackage)
where
unBoilerplate = map (\(E.Value p) -> p)
-- | An identifier specified in a package. Because this field has
-- quite liberal requirements, we often encounter various forms. A
-- name, a name and email, just an email, or maybe nothing at all.
@ -275,7 +208,6 @@ renderEmail = T.decodeUtf8 . toByteString
-- | Format a number with commas nicely.
formatNum :: Int -> Text
formatNum = sformat commas
-}
postPackageLikeR :: PackageName -> Handler ()
postPackageLikeR packageName = maybeAuthId >>= \muid -> case muid of

View File

@ -113,12 +113,7 @@ 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
let mliUrl mli = render $ haddockUrl name (mliPackageVersion mli) (mliName mli)
defaultLayout $ do
setTitle $ toHtml $ "Module list for " ++ toPathPiece name
$(widgetFile "doc-list")

View File

@ -5,56 +5,28 @@ module Handler.StackageSdist
import Import
import Data.BlobStore
import Stackage.Database
import Handler.Package (packagePage)
getStackageSdistR :: SnapName -> PackageNameVersion -> Handler TypedContent
getStackageSdistR slug (PNVTarball name version) = do
error "getStackageSdistR"
{-
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
let ident = stackageIdent stackage
msrc1 <- storeRead (CustomSdist ident name version)
msrc <-
case msrc1 of
Just src -> return $ Just src
Nothing -> sourceHackageSdist name version
case msrc of
Nothing -> notFound
Just src -> do
addHeader "content-disposition" $ concat
[ "attachment; filename=\""
, toPathPiece name
, "-"
, toPathPiece version
, ".tar.gz"
]
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
getStackageSdistR slug (PNVName name) = runDB $ do
Entity sid _ <- getBy404 $ UniqueSnapshot slug
mp <- selectFirst
[PackageStackage ==. sid, PackageName' ==. name]
[Desc PackageVersion]
case mp of
Nothing -> notFound
Just (Entity _ Package {..}) ->
redirect $ SnapshotR slug
$ StackageSdistR
$ PNVNameVersion name packageVersion
{- FIXME
getStackageSdistR slug (PNVNameVersion name version) = packagePage
name (Just version)
(do
Entity sid _ <- getBy404 $ UniqueSnapshot slug
let loop [] = return Nothing
loop (x:xs) = do
mdocs <- selectFirst x []
case mdocs of
Nothing -> loop xs
Just _ -> return mdocs
loop
[ [DocsName ==. name, DocsVersion ==. version, DocsSnapshot ==. Just sid]
, [DocsName ==. name, DocsVersion ==. version]
, [DocsName ==. name]
getStackageSdistR _ (PNVTarball name version) = do
redirect $ concat
-- unfortunately using insecure HTTP for cabal's sake
[ "http://hackage.fpcomplete.com/package/"
, toPathPiece name
, "-"
, toPathPiece version
, ".tar.gz"
]
) >>= sendResponse
-}
-}
getStackageSdistR sname (PNVName pname) = do
version <- versionHelper sname pname
redirect $ SnapshotR sname $ StackageSdistR $ PNVNameVersion pname version
getStackageSdistR sname (PNVNameVersion pname version) = do
version' <- versionHelper sname pname
if version == version'
then packagePage (Just (sname, version)) pname >>= sendResponse
else redirect $ SnapshotR sname $ StackageSdistR $ PNVNameVersion pname version'
versionHelper sname pname = do
Entity sid _ <- lookupSnapshot sname >>= maybe notFound return
Entity _ sp <- lookupSnapshotPackage sid (toPathPiece pname) >>= maybe notFound return
maybe notFound return $ fromPathPiece $ snapshotPackageVersion sp

View File

@ -13,6 +13,7 @@ import Yesod.Auth as Import
import Data.Slug (mkSlug)
import Data.WebsiteContent as Import (WebsiteContent (..))
import Data.Text.Read (decimal)
import Stackage.Database (SnapName)
requireAuthIdOrToken :: Handler UserId
requireAuthIdOrToken = do
@ -34,3 +35,15 @@ parseLtsPair t1 = do
t3 <- stripPrefix "." t2
(y, "") <- either (const Nothing) Just $ decimal t3
Just (x, y)
haddockUrl :: SnapName
-> Text -- ^ package-version
-> Text -- ^ module name
-> Route App
haddockUrl sname pkgver name = HaddockR sname
[ pkgver
, omap toDash name ++ ".html"
]
where
toDash '.' = '-'
toDash c = c

View File

@ -14,6 +14,16 @@ module Stackage.Database
, openStackageDatabase
, ModuleListingInfo (..)
, getSnapshotModules
, SnapshotPackage (..)
, lookupSnapshotPackage
, getDeprecated
, LatestInfo (..)
, getLatests
, getDeps
, getRevDeps
, Package (..)
, getPackage
, prettyName
) where
import Web.PathPieces (toPathPiece)
@ -65,6 +75,10 @@ Package
name Text
latest Text
synopsis Text
homepage Text
author Text
maintainer Text
licenseName Text
description Html
changelog Html
UniquePackage name
@ -80,12 +94,13 @@ Module
UniqueModule package name
Dep
user PackageId
usedBy PackageId
uses Text -- avoid circular dependency issue when loading database
range Text
UniqueDep user usedBy
UniqueDep user uses
Deprecated
package PackageId
inFavorOf [PackageId]
UniqueDeprecated package
|]
newtype StackageDatabase = StackageDatabase ConnectionPool
@ -158,12 +173,12 @@ createStackageDatabase fp = liftIO $ do
runResourceT $ do
flip runSqlPool pool $ sourcePackages root $$ getZipSink
( ZipSink (mapM_C addPackage)
*> ZipSink (foldlC getDeprecated [] >>= lift . mapM_ addDeprecated)
*> ZipSink (foldlC getDeprecated' [] >>= lift . mapM_ addDeprecated)
)
sourceBuildPlans root $$ mapM_C (flip runSqlPool pool . addPlan)
getDeprecated :: [Deprecation] -> Tar.Entry -> [Deprecation]
getDeprecated orig e =
getDeprecated' :: [Deprecation] -> Tar.Entry -> [Deprecation]
getDeprecated' orig e =
case (Tar.entryPath e, Tar.entryContent e) of
("deprecated.yaml", Tar.NormalFile lbs _) ->
case decode $ toStrict lbs of
@ -187,18 +202,31 @@ getPackageId x = do
, packageSynopsis = "Metadata not found"
, packageDescription = "Metadata not found"
, packageChangelog = mempty
, packageAuthor = ""
, packageMaintainer = ""
, packageHomepage = ""
, packageLicenseName = ""
}
addPackage :: Tar.Entry -> SqlPersistT (ResourceT IO) ()
addPackage e =
case ("packages/" `isPrefixOf` fp && takeExtension fp == ".yaml", Tar.entryContent e) of
(True, Tar.NormalFile lbs _) | Just pi <- decode $ toStrict lbs ->
insert_ Package
(True, Tar.NormalFile lbs _) | Just pi <- decode $ toStrict lbs -> do
pid <- insert Package
{ packageName = pack base
, packageLatest = display $ piLatest pi
, packageSynopsis = piSynopsis pi
, packageDescription = renderContent (piDescription pi) (piDescriptionType pi)
, packageChangelog = renderContent (piChangeLog pi) (piChangeLogType pi)
, packageAuthor = "FIXME author"
, packageMaintainer = "FIXME maintainer"
, packageHomepage = "FIXME homepage"
, packageLicenseName = "FIXME license name"
}
forM_ (mapToList $ piBasicDeps pi) $ \(uses, range) -> insert_ Dep
{ depUser = pid
, depUses = display uses
, depRange = display range
}
_ -> return ()
where
@ -293,11 +321,14 @@ lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot
lookupSnapshot name = run $ getBy $ UniqueSnapshot name
snapshotTitle :: Snapshot -> Text
snapshotTitle s =
concat [base, " - GHC ", snapshotGhc s]
snapshotTitle s = prettyName (snapshotName s) (snapshotGhc s)
prettyName :: SnapName -> Text -> Text
prettyName name ghc =
concat [base, " - GHC ", ghc]
where
base =
case snapshotName s of
case name of
SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
SNNightly d -> "Stackage Nightly " ++ tshow d
@ -358,3 +389,91 @@ getSnapshotModules sid = liftM (map toMLI) $ run $ do
{ mliName = name
, mliPackageVersion = concat [pkg, "-", version]
}
lookupSnapshotPackage
:: GetStackageDatabase m
=> SnapshotId
-> Text
-> m (Maybe (Entity SnapshotPackage))
lookupSnapshotPackage sid pname = run $ do
mp <- getBy $ UniquePackage pname
case mp of
Nothing -> return Nothing
Just (Entity pid _) -> getBy $ UniqueSnapshotPackage sid pid
getDeprecated :: GetStackageDatabase m => Text -> m (Bool, [Text])
getDeprecated name = run $ do
pids <- selectKeysList [PackageName ==. name] []
case pids of
[pid] -> do
mdep <- getBy $ UniqueDeprecated pid
case mdep of
Nothing -> return defRes
Just (Entity _ (Deprecated _ favors)) -> do
names <- mapM getName favors
return (True, catMaybes names)
_ -> return defRes
where
defRes = (False, [])
getName = fmap (fmap packageName) . get
data LatestInfo = LatestInfo
{ liSnapName :: !SnapName
, liVersion :: !Text
, liGhc :: !Text
}
deriving Show
getLatests :: GetStackageDatabase m
=> Text -- ^ package name
-> m [LatestInfo]
getLatests pname = run $ do
mnightly <- latestHelper pname $ \s ln -> s E.^. SnapshotId E.==. ln E.^. NightlySnap
mlts <- latestHelper pname $ \s ln -> s E.^. SnapshotId E.==. ln E.^. LtsSnap
return $ concat [mnightly, mlts]
latestHelper pname clause = fmap (fmap toLatest) $ E.select $ E.from $ \(s,ln,p,sp) -> do
E.where_ $
clause s ln E.&&.
(s E.^. SnapshotId E.==. sp E.^. SnapshotPackageSnapshot) E.&&.
(p E.^. PackageName E.==. E.val pname) E.&&.
(p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage)
E.orderBy [E.desc $ s E.^. SnapshotCreated]
E.limit 1
return
( s E.^. SnapshotName
, s E.^. SnapshotGhc
, sp E.^. SnapshotPackageVersion
)
where
toLatest (E.Value sname, E.Value ghc, E.Value version) = LatestInfo
{ liSnapName = sname
, liVersion = version
, liGhc = ghc
}
getDeps :: GetStackageDatabase m => Text -> m [(Text, Text)]
getDeps pname = run $ do
Just (Entity pid _) <- getBy $ UniquePackage pname
fmap (map toPair) $ E.select $ E.from $ \d -> do
E.where_ $
(d E.^. DepUser E.==. E.val pid)
E.orderBy [E.asc $ d E.^. DepUses]
return (d E.^. DepUses, d E.^. DepRange)
where
toPair (E.Value x, E.Value y) = (x, y)
getRevDeps :: GetStackageDatabase m => Text -> m [(Text, Text)]
getRevDeps pname = run $ do
fmap (map toPair) $ E.select $ E.from $ \(d,p) -> do
E.where_ $
(d E.^. DepUses E.==. E.val pname) E.&&.
(d E.^. DepUser E.==. p E.^. PackageId)
E.orderBy [E.asc $ p E.^. PackageName]
return (p E.^. PackageName, d E.^. DepRange)
where
toPair (E.Value x, E.Value y) = (x, y)
getPackage :: GetStackageDatabase m => Text -> m (Maybe (Entity Package))
getPackage = run . getBy . UniquePackage

View File

@ -12,7 +12,7 @@ $newline never
$forall (i, pn) <- ixInFavourOf
$if i /= 0
, #
<a href="@{PackageR pn}">
<a href="@{PackageR $ PackageName pn}">
#{pn}
<h1>
#{pn} #
@ -25,21 +25,11 @@ $newline never
<a href="#{url}">
#{url}
$maybe (_ltsMajor,_ltsMinor,pkgVersion,ltsSlug) <- mlts
<a href=@{SnapshotR ltsSlug StackageHomeR}>LTS Haskell
\ (
<a href=@{haddocksLink ltsSlug pkgVersion}>
#{pkgVersion}
)
$maybe _ <- mnightly
, #
$maybe (_nightlyDay,ghcVersion,pkgVersion,nightlySlug) <- mnightly
<a href=@{SnapshotR nightlySlug StackageHomeR}>Stackage Nightly GHC #{ghcVersion}
\ (
<a href=@{haddocksLink nightlySlug pkgVersion}>
#{pkgVersion}
)
$forall (idx, li) <- enumerate latests
$if idx /= 0
, #
<a href=@{SnapshotR (liSnapName li) StackageHomeR}>
#{prettyName (liSnapName li) (liGhc li)} (#{liVersion li})
<div .row>
<div .span12>
@ -73,7 +63,7 @@ $newline never
<div .authorship>
<span .license>
<a href="">
#{metadataLicenseName metadata} licensed #
#{packageLicenseName package} licensed #
$if null maintainers
and maintained #
$if not (null authors)
@ -113,7 +103,7 @@ $newline never
<a href="mailto:#{renderEmail email}">
#{renderEmail email}
$maybe (version, modules) <- mdocs
$maybe (sname, version, modules) <- mdocs
<div .docs>
<h4>
Module documentation for #{version}
@ -121,20 +111,20 @@ $newline never
<p>There are no documented modules for this package.
$else
<ul .docs-list>
$forall Module _ name url <- modules
$forall mname <- modules
<li>
<a href=#{url}>#{name}
<a href=@{haddockUrl sname (toPkgVer pname' version) mname}>#{mname}
$if not (LT.null (LT.renderHtml (metadataReadme metadata)))
$if not (LT.null (LT.renderHtml (packageDescription package)))
<div .markdown-container .readme-container>
<div .container .content>
<div .row>
<div .span12 .expanding>
#{metadataReadme metadata}
#{packageDescription package}
<div .bottom-gradient>
<i class="fa fa-angle-down">
$maybe log <- metadataChangelog metadata
$if not (LT.null (LT.renderHtml (packageChangelog package)))
<div .container .content>
<div .row>
<div .span12>
@ -143,7 +133,7 @@ $maybe log <- metadataChangelog metadata
<div .container>
<div .row>
<div .span12 .expanding>
#{log}
#{packageChangelog package}
<div .bottom-gradient>
<i class="fa fa-angle-down">
@ -153,19 +143,19 @@ $maybe log <- metadataChangelog metadata
<div .dependencies #dependencies>
Depends on
<div .dep-list>
$forall (i,name) <- deps
$forall (i,(name, range)) <- deps
$if i /= 0
, #
<a href=@{PackageR (PackageName name)}>
<a href=@{PackageR $ PackageName name} title=#{range}>
#{name}
$if not $ null revdeps
<div .reverse-dependencies .expanding #reverse-dependencies>
Used by
<div .dep-list>
$forall (i,name) <- revdeps
$forall (i,(name, range)) <- revdeps
$if i /= 0
, #
<a href=@{PackageR name}>
<a href=@{PackageR $ PackageName name} title=#{range}>
#{name}
<div .bottom-gradient>
<i class="fa fa-angle-down">