From f08978fadfd3c894bf04c0609fd0c265be736e3b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 12 May 2015 08:37:29 +0300 Subject: [PATCH] StackageHome mostly working --- Application.hs | 2 +- Handler/StackageHome.hs | 57 +-------- Stackage/Database.hs | 203 +++++++++++++++++++++++++++++---- Stackage/Database/Types.hs | 37 ++++++ stackage-server.cabal | 2 + templates/hoogle-form.hamlet | 2 +- templates/stackage-home.hamlet | 44 +++---- 7 files changed, 242 insertions(+), 105 deletions(-) create mode 100644 Stackage/Database/Types.hs diff --git a/Application.hs b/Application.hs index 512562f..0d84e16 100644 --- 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 diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index d793b51..bcab73f 100644 --- 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 diff --git a/Stackage/Database.hs b/Stackage/Database.hs index c2fe8b0..73cfa9f 100644 --- 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 + } diff --git a/Stackage/Database/Types.hs b/Stackage/Database/Types.hs new file mode 100644 index 0000000..0f04339 --- /dev/null +++ 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 diff --git a/stackage-server.cabal b/stackage-server.cabal index ad36c46..3710475 100644 --- 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) diff --git a/templates/hoogle-form.hamlet b/templates/hoogle-form.hamlet index cbde565..a352abe 100644 --- a/templates/hoogle-form.hamlet +++ b/templates/hoogle-form.hamlet @@ -1,4 +1,4 @@ -
+