StackageHome mostly working

2026-01-11 19:58:28 +01:00 · 2015-05-12 08:37:29 +03:00 · 2015-05-12 08:37:29 +03:00 · f08978fadf
commit f08978fadf
parent 7f3bb119f4
7 changed files with 242 additions and 105 deletions
--- a/Application.hs
+++ b/Application.hs
@ -165,7 +165,7 @@ makeFoundation useEcho conf = do
        threadDelay $ 1000 * 1000 * 60 * 20
        grRefresh websiteContent'

-    stackageDatabase' <- liftIO $ loadStackageDatabase >>= newIORef
+    stackageDatabase' <- liftIO $ loadStackageDatabase False >>= newIORef

    env <- getEnvironment

--- a/Handler/StackageHome.hs
+++ b/Handler/StackageHome.hs
@ -11,64 +11,19 @@ import qualified Database.Esqueleto as E
 import Stackage.Database

 getStackageHomeR :: SnapName -> Handler Html
-getStackageHomeR slug = do
-    error "getStackageHomeR"
-    {-
-    stackage <- runDB $ do
-        Entity _ stackage <- getBy404 $ UniqueSnapshot slug
-        return stackage
+getStackageHomeR name = do
+    db <- getStackageDatabase
+    Entity sid snapshot <- lookupSnapshot db name >>= maybe notFound return

-    let minclusive = Just False
-        base = maybe 0 (const 1) minclusive :: Int
-        hoogleForm =
+    let hoogleForm =
            let queryText = "" :: Text
                exact = False
            in $(widgetFile "hoogle-form")
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
    defaultLayout $ do
-        setTitle $ toHtml $ stackageTitle stackage
-        let maxPackages = 5000
-        (packageListClipped, packages') <- handlerToWidget $ runDB $ do
-            packages' <- 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
-                          )
-                E.limit maxPackages
-                return
-                    ( m E.^. MetadataName
-                    , m E.^. MetadataSynopsis
-                    , E.max_ (p E.^. PackageVersion)
-                    , E.max_ $ E.case_
-                        [ ( p E.^. PackageHasHaddocks
-                          , p E.^. PackageVersion
-                          )
-                        ]
-                        (E.val (Version ""))
-                    )
-            packageCount <- count [PackageStackage ==. sid]
-            let packageListClipped = packageCount > maxPackages
-            return (packageListClipped, packages')
-        let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
-                ( E.unValue name
-                , fmap unVersion $ E.unValue latestVersion
-                , 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
+        setTitle $ toHtml $ snapshotTitle snapshot
+        packages <- getPackages db sid
        $(widgetFile "stackage-home")
  where strip x = fromMaybe x (stripSuffix "." x)
-    -}

 getStackageCabalConfigR :: SnapName -> Handler TypedContent
 getStackageCabalConfigR slug = do
--- a/Stackage/Database.hs
+++ b/Stackage/Database.hs
@ -1,45 +1,202 @@
 module Stackage.Database
    ( StackageDatabase
    , SnapName (..)
+    , Snapshot (..)
    , loadStackageDatabase
    , newestLTS
    , newestLTSMajor
    , newestNightly
+    , lookupSnapshot
+    , snapshotTitle
+    , PackageListingInfo (..)
+    , getPackages
    ) where

 import ClassyPrelude.Conduit
 import Data.Time
-import Web.PathPieces
-import Data.Text.Read (decimal)
+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 Web.PathPieces (fromPathPiece)
+import Data.Yaml (decodeFileEither)
+import Database.Persist
+import Database.Persist.Sqlite
+import Database.Persist.TH
+import Control.Monad.Logger
+import Control.Concurrent (forkIO)
+import System.IO.Temp
+import qualified Database.Esqueleto as E

-data SnapName = SNLts !Int !Int
-              | SNNightly !Day
-    deriving (Eq, Read, Show)
-instance PathPiece SnapName where
-    toPathPiece (SNLts x y) = concat ["lts-", tshow x, ".", tshow y]
-    toPathPiece (SNNightly d) = "nightly-" ++ tshow d
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Snapshot
+    name SnapName
+    ghc Text
+    created Day
+    UniqueSnapshot name
+Lts
+    snap SnapshotId
+    major Int
+    minor Int
+    UniqueLts major minor
+Nightly
+    snap SnapshotId
+    day Day
+    UniqueNightly day
+Package
+    name Text
+    latest Text
+    synopsis Text
+    UniquePackage name
+SnapshotPackage
+    snapshot SnapshotId
+    package PackageId
+    isCore Bool
+    version Text
+    UniqueSnapshotPackage snapshot package
+|]

-    fromPathPiece t0 =
-        nightly <|> lts
+newtype StackageDatabase = StackageDatabase ConnectionPool
+
+sourceBuildPlans :: MonadResource m => Producer m (SnapName, BuildPlan)
+sourceBuildPlans = do
+    root <- liftIO $ fmap (</> "database") $ fmap fpFromString $ getAppUserDataDirectory "stackage"
+    liftIO $ F.createTree root
+    forM_ ["lts-haskell", "stackage-nightly"] $ \dir -> do
+        dir <- liftIO $ cloneOrUpdate root dir
+        sourceDirectory dir =$= concatMapMC go
+  where
+    go fp | Just name <- nameFromFP fp = liftIO $ do
+        bp <- decodeFileEither (fpToString fp) >>= either throwM return
+        return $ Just (name, bp)
+    go _ = return Nothing
+
+    nameFromFP fp = 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
-        nightly = fmap SNNightly $ stripPrefix "nightly-" t0 >>= readMay
-        lts = do
-            t1 <- stripPrefix "lts-" t0
-            Right (x, t2) <- Just $ decimal t1
-            t3 <- stripPrefix "." t2
-            Right (y, "") <- Just $ decimal t3
-            return $ SNLts x y
+        url = "https://github.com/fpco/" ++ name ++ ".git"
+        dest = root </> fpFromString name

-data StackageDatabase = StackageDatabase
+        runIn dir cmd args =
+            withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
+          where
+            cp = (proc cmd args) { cwd = Just $ fpToString dir }

-loadStackageDatabase :: IO StackageDatabase
-loadStackageDatabase = return StackageDatabase
+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
+  where
+    forker
+        | toBlock = id
+        | otherwise = void . forkIO
+
+addPlan :: (SnapName, BuildPlan) -> SqlPersistT (ResourceT IO) ()
+addPlan (name, bp) = do
+    sid <- insert Snapshot
+        { snapshotName = name
+        , snapshotGhc = display $ siGhcVersion $ bpSystemInfo bp
+        , snapshotCreated =
+            case name of
+                SNNightly d -> d
+                SNLts _ _ -> fromGregorian 1970 1 1 -- FIXME
+        }
+    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
+        insert_ SnapshotPackage
+            { snapshotPackageSnapshot = sid
+            , snapshotPackagePackage = pid
+            , snapshotPackageIsCore = isCore
+            , snapshotPackageVersion = version
+            }
+    case name of
+        SNLts x y -> insert_ Lts
+            { ltsSnap = sid
+            , ltsMajor = x
+            , ltsMinor = y
+            }
+        SNNightly d -> insert_ Nightly
+            { nightlySnap = sid
+            , nightlyDay = d
+            }
+  where
+    allPackages = mapToList
+        $ fmap (, True) (siCorePackages $ bpSystemInfo bp)
+       ++ fmap ((, False) . ppVersion) (bpPackages bp)
+
+run :: MonadIO m => StackageDatabase -> SqlPersistT IO a -> m a
+run (StackageDatabase pool) inner = liftIO $ runSqlPool inner pool

 newestLTS :: MonadIO m => StackageDatabase -> m (Maybe (Int, Int))
-newestLTS _ = return $ Just (2, 8)
+newestLTS db =
+    run db $ liftM (fmap go) $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
+  where
+    go (Entity _ lts) = (ltsMajor lts, ltsMinor lts)

 newestLTSMajor :: MonadIO m => StackageDatabase -> Int -> m (Maybe Int)
-newestLTSMajor _ _ = return $ Just 7
+newestLTSMajor db x =
+    run db $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]

 newestNightly :: MonadIO m => StackageDatabase -> m (Maybe Day)
-newestNightly _ = return $ Just $ fromGregorian 2015 4 3
+newestNightly db =
+    run db $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]
+
+lookupSnapshot :: MonadIO m => StackageDatabase -> SnapName -> m (Maybe (Entity Snapshot))
+lookupSnapshot db name = run db $ getBy $ UniqueSnapshot name
+
+snapshotTitle :: Snapshot -> Text
+snapshotTitle s =
+    concat [base, " - GHC ", snapshotGhc s]
+  where
+    base =
+        case snapshotName s of
+            SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
+            SNNightly d -> "Stackage Nightly " ++ tshow d
+
+data PackageListingInfo = PackageListingInfo
+    { pliName :: !Text
+    , pliVersion :: !Text
+    , pliSynopsis :: !Text
+    }
+
+getPackages :: MonadIO m => StackageDatabase -> SnapshotId -> m [PackageListingInfo]
+getPackages db sid = liftM (map toPLI) $ run db $ do
+    E.select $ E.from $ \(p,sp) -> do
+        E.where_ $
+            (p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
+            (sp E.^. SnapshotPackageSnapshot E.==. E.val sid)
+        E.orderBy [E.asc $ p E.^. PackageName]
+        return
+            ( p E.^. PackageName
+            , p E.^. PackageSynopsis
+            , sp E.^. SnapshotPackageVersion
+            )
+  where
+    toPLI (E.Value name, E.Value synopsis, E.Value version) = PackageListingInfo
+        { pliName = name
+        , pliVersion = version
+        , pliSynopsis = synopsis
+        }
--- a/Stackage/Database/Types.hs
+++ b/Stackage/Database/Types.hs
@ -0,0 +1,37 @@
+module Stackage.Database.Types
+    ( SnapName (..)
+    ) where
+
+import ClassyPrelude.Conduit
+import Data.Time
+import Web.PathPieces
+import Data.Text.Read (decimal)
+import Database.Persist
+import Database.Persist.Sql
+
+data SnapName = SNLts !Int !Int
+              | SNNightly !Day
+    deriving (Eq, Read, Show)
+instance PersistField SnapName where
+    toPersistValue = toPersistValue . toPathPiece
+    fromPersistValue v = do
+        t <- fromPersistValue v
+        case fromPathPiece t of
+            Nothing -> Left $ "Invalid SnapName: " ++ t
+            Just x -> return x
+instance PersistFieldSql SnapName where
+    sqlType = sqlType . fmap toPathPiece
+instance PathPiece SnapName where
+    toPathPiece (SNLts x y) = concat ["lts-", tshow x, ".", tshow y]
+    toPathPiece (SNNightly d) = "nightly-" ++ tshow d
+
+    fromPathPiece t0 =
+        nightly <|> lts
+      where
+        nightly = fmap SNNightly $ stripPrefix "nightly-" t0 >>= readMay
+        lts = do
+            t1 <- stripPrefix "lts-" t0
+            Right (x, t2) <- Just $ decimal t1
+            t3 <- stripPrefix "." t2
+            Right (y, "") <- Just $ decimal t3
+            return $ SNLts x y
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@ -27,6 +27,7 @@ library
                     Data.WebsiteContent
                     Types
                     Stackage.Database
+                     Stackage.Database.Types
                     Handler.Home
                     Handler.Snapshots
                     Handler.Profile
@ -165,6 +166,7 @@ library
                 , streaming-commons
                 , classy-prelude-conduit
                 , path-pieces
+                 , persistent-sqlite

 executable         stackage-server
    if flag(library-only)
--- a/templates/hoogle-form.hamlet
+++ b/templates/hoogle-form.hamlet
@ -1,4 +1,4 @@
-<form .hoogle action=@{SnapshotR slug HoogleR}>
+<form .hoogle action=@{SnapshotR name HoogleR}>
    <input type=search autofocus name=q value=#{queryText} placeholder="Hoogle Search Phrase" .search>
    <input .btn type="submit" value="Search">
    <label .checkbox .exact-lookup for=exact title="Only find identifiers matching your search term precisely">
--- a/templates/stackage-home.hamlet
+++ b/templates/stackage-home.hamlet
@ -1,78 +1,64 @@
 $newline never
 <div .container .content>
    <h1>
-        #{stackageTitle stackage}
+        #{snapshotTitle snapshot}
    <p>
-        Published on #{yearMonthDay (stackageUploaded stackage)}
+        Published on #{yearMonthDay (snapshotCreated snapshot)}
        <span .separator>
        <span>
-            <a href=@{SnapshotR slug StackageCabalConfigR}>
+            <a href=@{SnapshotR name StackageCabalConfigR}>
                \cabal.config
    <h3>Setup guide
    <div class="accordion" id="accordion2">

      <div class="accordion-group">
        <div class="accordion-heading">
-          <span class="accordion-toggle" data-parent="#accordion#{base + 0}" href="#collapse1">
+          <span class="accordion-toggle" data-parent="#accordion0" href="#collapse1">
            <span .number>1
            Download the #
-            <a href=@{SnapshotR slug StackageCabalConfigR}?download=true>
+            <a href=@{SnapshotR name StackageCabalConfigR}?download=true>
              \cabal.config
            \ into your project or sandbox root directory

      <div class="accordion-group">
        <div class="accordion-heading">
-          <span class="accordion-toggle" data-toggle="collapse" data-parent="#accordion#{base + 0}" href="#collapse2">
+          <span class="accordion-toggle" data-toggle="collapse" data-parent="#accordion0" href="#collapse2">
            <span .number>2
            <code>cabal update
      <div class="accordion-group">
        <div class="accordion-heading">
-          <span class="accordion-toggle" data-toggle="collapse" data-parent="#accordion#{base + 0}" href="#collapse3">
+          <span class="accordion-toggle" data-toggle="collapse" data-parent="#accordion0" href="#collapse3">
            <span .number>3
            <code>cabal install

    <p>
        <strong>Note: #
        For a global installation, please use #
-        <a href=@{SnapshotR slug StackageCabalConfigR}?global=true>
+        <a href=@{SnapshotR name StackageCabalConfigR}?global=true>
            the global configuration instructions

    <h3>Hoogle (experimental)
    ^{hoogleForm}
-    <a href=@{SnapshotR slug HoogleDatabaseR}>
+    <a href=@{SnapshotR name HoogleDatabaseR}>
      Download this hoogle database

    <h3>Packages

    <p>
-        <a href=@{SnapshotR slug DocsR}>View documentation by modules
+        <a href=@{SnapshotR name DocsR}>View documentation by modules

 <div .container .content>
    <div .packages>
-        $if packageListClipped
-            <p>
-                Note: due to a large number of packages, not all packages are display.
-                For a full listing, please see #
-                <a href=@{SnapshotR slug StackageMetadataR}>the metadata listing
-                .
        <table .table>
            <thead>
                <th>Package
-                <th>Docs
                <th>Synopsis
            <tbody>
-                $forall (name,mversion,synopsis,mdoc) <- packages
+                $forall pli <- packages
                    <tr>
                        <td>
-                            $maybe version <- mversion
-                                <a href=@{SnapshotR slug $ StackageSdistR $ PNVNameVersion name $ Version version}>
-                                    #{name}
-                                    -#{asText version}
-                            $nothing
-                                <a href=@{SnapshotR slug $ StackageSdistR $ PNVName name}>
-                                    #{name}
+                            <a href=@{SnapshotR name $ StackageSdistR $ PNVNameVersion (PackageName $ toPathPiece $ pliName pli) $ Version (pliVersion pli)}>
+                                #{pliName pli}
+                                -#{pliVersion pli}
                        <td>
-                            $maybe doc <- mdoc
-                                <a href=@{doc}>Docs
-                        <td>
-                            #{synopsis}
+                            #{pliSynopsis pli}