From 8c23324d60e5ac907f35be776e80f8a83e1568cc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 May 2015 11:38:38 +0300 Subject: [PATCH] Grab data from all-cabal-metadata --- Application.hs | 8 +- Foundation.hs | 6 +- Stackage/Database.hs | 163 ++++++++++++++++++++++++++--------- Stackage/Database/Haddock.hs | 59 +++++++++++++ stackage-server.cabal | 3 + 5 files changed, 192 insertions(+), 47 deletions(-) create mode 100644 Stackage/Database/Haddock.hs diff --git a/Application.hs b/Application.hs index 0d84e16..d54c02b 100644 --- a/Application.hs +++ b/Application.hs @@ -16,7 +16,7 @@ import Data.Streaming.Network (bindPortTCP) import Data.Time (diffUTCTime) import qualified Database.Esqueleto as E import qualified Database.Persist -import Filesystem (getModified, removeTree) +import Filesystem (getModified, removeTree, isFile) import Import hiding (catch) import Language.Haskell.TH.Syntax (Loc(..)) import Network.Wai (Middleware, responseLBS) @@ -39,7 +39,7 @@ import System.IO (hSetBuffering, BufferMode (LineBuffering)) import qualified Data.ByteString as S import qualified Data.Text as T import System.Process (rawSystem) -import Stackage.Database (loadStackageDatabase) +import Stackage.Database (createStackageDatabase, openStackageDatabase) import qualified Echo @@ -165,7 +165,9 @@ makeFoundation useEcho conf = do threadDelay $ 1000 * 1000 * 60 * 20 grRefresh websiteContent' - stackageDatabase' <- liftIO $ loadStackageDatabase False >>= newIORef + let dbfile = "stackage.sqlite3" + unlessM (isFile dbfile) $ createStackageDatabase dbfile + stackageDatabase' <- openStackageDatabase dbfile env <- getEnvironment diff --git a/Foundation.hs b/Foundation.hs index e55d7e1..f4c43bd 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -37,7 +37,7 @@ data App = App , genIO :: MWC.GenIO , blobStore :: BlobStore StoreKey , websiteContent :: GitRepo WebsiteContent - , stackageDatabase :: IORef StackageDatabase + , stackageDatabase :: StackageDatabase } instance HasBlobStore App StoreKey where @@ -276,6 +276,6 @@ getExtra = fmap (appExtra . settings) getYesod -- https://github.com/yesodweb/yesod/wiki/Sending-email instance GetStackageDatabase Handler where - getStackageDatabase = getYesod >>= readIORef . stackageDatabase + getStackageDatabase = fmap stackageDatabase getYesod instance GetStackageDatabase (WidgetT App IO) where - getStackageDatabase = getYesod >>= readIORef . stackageDatabase + getStackageDatabase = fmap stackageDatabase getYesod diff --git a/Stackage/Database.hs b/Stackage/Database.hs index 2f5edae..b84e9a2 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -3,7 +3,6 @@ module Stackage.Database , GetStackageDatabase (..) , SnapName (..) , Snapshot (..) - , loadStackageDatabase , newestLTS , newestLTSMajor , newestNightly @@ -11,16 +10,28 @@ module Stackage.Database , snapshotTitle , PackageListingInfo (..) , getPackages + , createStackageDatabase + , openStackageDatabase ) where +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import Text.Markdown (Markdown (..)) +import System.Directory (removeFile) +import Stackage.Database.Haddock +import System.FilePath (takeBaseName, takeExtension) import ClassyPrelude.Conduit import Data.Time +import Text.Blaze.Html (Html, toHtml) +import Yesod.Form.Fields (Textarea (..)) import Stackage.Database.Types import System.Directory (getAppUserDataDirectory, getTemporaryDirectory) import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import Data.Conduit.Process import Stackage.Types +import Stackage.Metadata +import Stackage.PackageIndex.Conduit import Web.PathPieces (fromPathPiece) import Data.Yaml (decodeFileEither) import Database.Persist @@ -30,6 +41,7 @@ import Control.Monad.Logger import Control.Concurrent (forkIO) import System.IO.Temp import qualified Database.Esqueleto as E +import Data.Yaml (decode) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Snapshot @@ -50,6 +62,8 @@ Package name Text latest Text synopsis Text + description Html + changelog Html UniquePackage name SnapshotPackage snapshot SnapshotId @@ -57,6 +71,14 @@ SnapshotPackage isCore Bool version Text UniqueSnapshotPackage snapshot package +Dep + user PackageId + usedBy PackageId + range Text + UniqueDep user usedBy +Deprecated + package PackageId + inFavorOf [PackageId] |] newtype StackageDatabase = StackageDatabase ConnectionPool @@ -64,12 +86,23 @@ newtype StackageDatabase = StackageDatabase ConnectionPool class MonadIO m => GetStackageDatabase m where getStackageDatabase :: m StackageDatabase -sourceBuildPlans :: MonadResource m => Producer m (SnapName, BuildPlan) -sourceBuildPlans = do - root <- liftIO $ fmap ( "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage" - liftIO $ F.createTree root +sourcePackages :: MonadResource m => FilePath -> Producer m Tar.Entry +sourcePackages root = do + dir <- liftIO $ cloneOrUpdate root "commercialhaskell" "all-cabal-metadata" + bracketP + (do + (fp, h) <- openBinaryTempFile "/tmp" "all-cabal-metadata.tar" + hClose h + return fp) + removeFile + $ \fp -> do + liftIO $ runIn dir "git" ["archive", "--output", fp, "--format", "tar", "master"] + sourceTarFile False fp + +sourceBuildPlans :: MonadResource m => FilePath -> Producer m (SnapName, BuildPlan) +sourceBuildPlans root = do forM_ ["lts-haskell", "stackage-nightly"] $ \dir -> do - dir <- liftIO $ cloneOrUpdate root dir + dir <- liftIO $ cloneOrUpdate root "fpco" dir sourceDirectory dir =$= concatMapMC go where go fp | Just name <- nameFromFP fp = liftIO $ do @@ -81,39 +114,89 @@ sourceBuildPlans = do base <- stripSuffix ".yaml" $ fpToText $ filename fp fromPathPiece base - cloneOrUpdate root name = do - exists <- F.isDirectory dest - if exists - then do - let run = runIn dest - run "git" ["fetch"] - run "git" ["reset", "--hard", "origin/master"] - else runIn root "git" ["clone", url, name] - return dest - where - url = "https://github.com/fpco/" ++ name ++ ".git" - dest = root fpFromString name - - runIn dir cmd args = - withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () - where - cp = (proc cmd args) { cwd = Just $ fpToString dir } - -loadStackageDatabase :: MonadIO m - => Bool -- ^ block until all snapshots added? - -> m StackageDatabase -loadStackageDatabase toBlock = liftIO $ do - tmp <- getTemporaryDirectory - (fp, h) <- openBinaryTempFile "/tmp" "stackage-database.sqlite3" - hClose h - pool <- runNoLoggingT $ createSqlitePool (pack fp) 7 - runSqlPool (runMigration migrateAll) pool - forker $ runResourceT $ sourceBuildPlans $$ mapM_C (flip runSqlPool pool . addPlan) - return $ StackageDatabase pool +cloneOrUpdate :: FilePath -> String -> String -> IO FilePath +cloneOrUpdate root org name = do + exists <- F.isDirectory dest + if exists + then do + let run = runIn dest + run "git" ["fetch"] + run "git" ["reset", "--hard", "origin/master"] + else runIn root "git" ["clone", url, name] + return dest where - forker - | toBlock = id - | otherwise = void . forkIO + url = "https://github.com/" ++ org ++ "/" ++ name ++ ".git" + dest = root fpFromString name + +runIn :: FilePath -> String -> [String] -> IO () +runIn dir cmd args = + withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () + where + cp = (proc cmd args) { cwd = Just $ fpToString dir } + +openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase +openStackageDatabase fp = liftIO $ fmap StackageDatabase $ runNoLoggingT $ createSqlitePool (fpToText fp) 7 + +createStackageDatabase :: MonadIO m => FilePath -> m () +createStackageDatabase fp = liftIO $ do + void $ tryIO $ removeFile $ fpToString fp + StackageDatabase pool <- openStackageDatabase fp + runSqlPool (runMigration migrateAll) pool + root <- liftIO $ fmap ( "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage" + F.createTree root + runResourceT $ do + flip runSqlPool pool $ sourcePackages root $$ getZipSink + ( ZipSink (mapM_C addPackage) + *> ZipSink (foldlC getDeprecated [] >>= lift . mapM_ addDeprecated) + ) + sourceBuildPlans root $$ mapM_C (flip runSqlPool pool . addPlan) + +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 + Just x -> x + Nothing -> orig + _ -> orig + +addDeprecated :: Deprecation -> SqlPersistT (ResourceT IO) () +addDeprecated (Deprecation name others) = do + name' <- getPackageId name + others' <- mapM getPackageId $ setToList others + insert_ $ Deprecated name' others' + +getPackageId x = do + keys <- selectKeysList [PackageName ==. x] [LimitTo 1] + case keys of + k:_ -> return k + [] -> insert Package + { packageName = x + , packageLatest = "unknown" + , packageSynopsis = "Metadata not found" + , packageDescription = "Metadata not found" + , packageChangelog = mempty + } + +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 + { packageName = pack base + , packageLatest = display $ piLatest pi + , packageSynopsis = piSynopsis pi + , packageDescription = renderContent (piDescription pi) (piDescriptionType pi) + , packageChangelog = renderContent (piChangeLog pi) (piChangeLogType pi) + } + _ -> return () + where + fp = Tar.entryPath e + base = takeBaseName fp + + renderContent txt "markdown" = toHtml $ Markdown $ fromStrict txt + renderContent txt "haddock" = renderHaddock txt + renderContent txt _ = toHtml $ Textarea txt addPlan :: (SnapName, BuildPlan) -> SqlPersistT (ResourceT IO) () addPlan (name, bp) = do @@ -127,9 +210,7 @@ addPlan (name, bp) = do } forM_ allPackages $ \(display -> name, (display -> version, isCore)) -> do mp <- getBy $ UniquePackage name - pid <- case mp of - Nothing -> insert $ Package name "FIXME latest version" "FIXME synopsis" - Just (Entity pid _) -> return pid + pid <- getPackageId name insert_ SnapshotPackage { snapshotPackageSnapshot = sid , snapshotPackagePackage = pid diff --git a/Stackage/Database/Haddock.hs b/Stackage/Database/Haddock.hs new file mode 100644 index 0000000..f97689f --- /dev/null +++ b/Stackage/Database/Haddock.hs @@ -0,0 +1,59 @@ +module Stackage.Database.Haddock + ( renderHaddock + ) where + +import Text.Blaze.Html (unsafeByteString) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Documentation.Haddock.Parser as Haddock +import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..)) +import ClassyPrelude.Conduit +import Text.Blaze.Html (Html, toHtml) + +renderHaddock :: Text -> Html +renderHaddock = hToHtml . Haddock.toRegular . Haddock.parseParas . unpack + +-- | Convert a Haddock doc to HTML. +hToHtml :: DocH String String -> Html +hToHtml = + go + where + go :: DocH String String -> Html + go DocEmpty = mempty + go (DocAppend x y) = go x ++ go y + go (DocString x) = toHtml x + go (DocParagraph x) = H.p $ go x + go (DocIdentifier s) = H.code $ toHtml s + go (DocIdentifierUnchecked s) = H.code $ toHtml s + go (DocModule s) = H.code $ toHtml s + go (DocWarning x) = H.span H.! A.class_ "warning" $ go x + go (DocEmphasis x) = H.em $ go x + go (DocMonospaced x) = H.code $ go x + go (DocBold x) = H.strong $ go x + go (DocUnorderedList xs) = H.ul $ foldMap (H.li . go) xs + go (DocOrderedList xs) = H.ol $ foldMap (H.li . go) xs + go (DocDefList xs) = H.dl $ flip foldMap xs $ \(x, y) -> + H.dt (go x) ++ H.dd (go y) + go (DocCodeBlock x) = H.pre $ H.code $ go x + go (DocHyperlink (Hyperlink url mlabel)) = + H.a H.! A.href (H.toValue url) $ toHtml label + where + label = fromMaybe url mlabel + go (DocPic (Picture url mtitle)) = + H.img H.! A.src (H.toValue url) H.! A.title (H.toValue $ fromMaybe mempty mtitle) + go (DocAName s) = H.div H.! A.id (H.toValue s) $ mempty + go (DocProperty s) = H.pre $ H.code $ toHtml s + go (DocExamples es) = flip foldMap es $ \(Example exp' ress) -> + H.div H.! A.class_ "example" $ do + H.pre H.! A.class_ "expression" $ H.code $ toHtml exp' + flip foldMap ress $ \res -> + H.pre H.! A.class_ "result" $ H.code $ toHtml res + go (DocHeader (Header level content)) = + wrapper level $ go content + where + wrapper 1 = H.h1 + wrapper 2 = H.h2 + wrapper 3 = H.h3 + wrapper 4 = H.h4 + wrapper 5 = H.h5 + wrapper _ = H.h6 diff --git a/stackage-server.cabal b/stackage-server.cabal index 3710475..7f07848 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -27,6 +27,7 @@ library Data.WebsiteContent Types Stackage.Database + Stackage.Database.Haddock Stackage.Database.Types Handler.Home Handler.Snapshots @@ -167,6 +168,8 @@ library , classy-prelude-conduit , path-pieces , persistent-sqlite + , stackage-metadata + , filepath executable stackage-server if flag(library-only)