Grab data from all-cabal-metadata

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
 

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

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

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

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)