diff --git a/Handler/Package.hs b/Handler/Package.hs index b4a26ff..ddb6a94 100644 --- a/Handler/Package.hs +++ b/Handler/Package.hs @@ -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 diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index dc73bbd..995d926 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -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") diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index d5b2563..ddcf68d 100644 --- a/Handler/StackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -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 diff --git a/Import.hs b/Import.hs index 9a53b4d..db9fcdd 100644 --- a/Import.hs +++ b/Import.hs @@ -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 diff --git a/Stackage/Database.hs b/Stackage/Database.hs index 782b4f1..2faf8e8 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -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 diff --git a/templates/package.hamlet b/templates/package.hamlet index 8ee3401..f7b8caf 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -12,7 +12,7 @@ $newline never $forall (i, pn) <- ixInFavourOf $if i /= 0 , # - + #{pn}

#{pn} # @@ -25,21 +25,11 @@ $newline never #{url} - $maybe (_ltsMajor,_ltsMinor,pkgVersion,ltsSlug) <- mlts - LTS Haskell - \ ( - - #{pkgVersion} - ) - $maybe _ <- mnightly - , # - - $maybe (_nightlyDay,ghcVersion,pkgVersion,nightlySlug) <- mnightly - Stackage Nightly GHC #{ghcVersion} - \ ( - - #{pkgVersion} - ) + $forall (idx, li) <- enumerate latests + $if idx /= 0 + , # + + #{prettyName (liSnapName li) (liGhc li)} (#{liVersion li})
@@ -73,7 +63,7 @@ $newline never
- #{metadataLicenseName metadata} licensed # + #{packageLicenseName package} licensed # $if null maintainers and maintained # $if not (null authors) @@ -113,7 +103,7 @@ $newline never #{renderEmail email} - $maybe (version, modules) <- mdocs + $maybe (sname, version, modules) <- mdocs

Module documentation for #{version} @@ -121,20 +111,20 @@ $newline never

There are no documented modules for this package. $else