mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
346 lines
11 KiB
Haskell
346 lines
11 KiB
Haskell
module Stackage.Database
|
|
( StackageDatabase
|
|
, GetStackageDatabase (..)
|
|
, SnapName (..)
|
|
, Snapshot (..)
|
|
, newestLTS
|
|
, newestLTSMajor
|
|
, newestNightly
|
|
, lookupSnapshot
|
|
, snapshotTitle
|
|
, PackageListingInfo (..)
|
|
, getPackages
|
|
, createStackageDatabase
|
|
, openStackageDatabase
|
|
, ModuleListingInfo (..)
|
|
, getSnapshotModules
|
|
) where
|
|
|
|
import Web.PathPieces (toPathPiece)
|
|
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
|
|
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
|
|
import Data.Yaml (decode)
|
|
|
|
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
|
|
description Html
|
|
changelog Html
|
|
UniquePackage name
|
|
SnapshotPackage
|
|
snapshot SnapshotId
|
|
package PackageId
|
|
isCore Bool
|
|
version Text
|
|
UniqueSnapshotPackage snapshot package
|
|
Module
|
|
package SnapshotPackageId
|
|
name Text
|
|
UniqueModule package name
|
|
Dep
|
|
user PackageId
|
|
usedBy PackageId
|
|
range Text
|
|
UniqueDep user usedBy
|
|
Deprecated
|
|
package PackageId
|
|
inFavorOf [PackageId]
|
|
|]
|
|
|
|
newtype StackageDatabase = StackageDatabase ConnectionPool
|
|
|
|
class MonadIO m => GetStackageDatabase m where
|
|
getStackageDatabase :: m StackageDatabase
|
|
|
|
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, Either BuildPlan DocMap)
|
|
sourceBuildPlans root = do
|
|
forM_ ["lts-haskell", "stackage-nightly"] $ \dir -> do
|
|
dir <- liftIO $ cloneOrUpdate root "fpco" dir
|
|
sourceDirectory dir =$= concatMapMC (go Left)
|
|
let docdir = dir </> "docs"
|
|
whenM (liftIO $ F.isDirectory docdir) $
|
|
sourceDirectory docdir =$= concatMapMC (go Right)
|
|
where
|
|
go wrapper fp | Just name <- nameFromFP fp = liftIO $ do
|
|
bp <- decodeFileEither (fpToString fp) >>= either throwM return
|
|
return $ Just (name, wrapper bp)
|
|
go _ _ = return Nothing
|
|
|
|
nameFromFP fp = do
|
|
base <- stripSuffix ".yaml" $ fpToText $ filename fp
|
|
fromPathPiece base
|
|
|
|
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
|
|
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
|
|
putStrLn "Initial migration"
|
|
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, Either BuildPlan DocMap) -> SqlPersistT (ResourceT IO) ()
|
|
addPlan (name, Left bp) = do
|
|
putStrLn $ "Adding build plan: " ++ toPathPiece name
|
|
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 <- getPackageId name
|
|
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)
|
|
addPlan (name, Right dm) = do
|
|
[sid] <- selectKeysList [SnapshotName ==. name] []
|
|
putStrLn $ "Adding doc map: " ++ toPathPiece name
|
|
forM_ (mapToList dm) $ \(pkg, pd) -> do
|
|
[pid] <- selectKeysList [PackageName ==. pkg] []
|
|
[spid] <- selectKeysList [SnapshotPackageSnapshot ==. sid, SnapshotPackagePackage ==. pid] []
|
|
forM_ (mapToList $ pdModules pd) $ \(name, paths) ->
|
|
insert_ Module
|
|
{ modulePackage = spid
|
|
, moduleName = name
|
|
}
|
|
|
|
run :: GetStackageDatabase m => SqlPersistT IO a -> m a
|
|
run inner = do
|
|
StackageDatabase pool <- getStackageDatabase
|
|
liftIO $ runSqlPool inner pool
|
|
|
|
newestLTS :: GetStackageDatabase m => m (Maybe (Int, Int))
|
|
newestLTS =
|
|
run $ liftM (fmap go) $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
|
|
where
|
|
go (Entity _ lts) = (ltsMajor lts, ltsMinor lts)
|
|
|
|
newestLTSMajor :: GetStackageDatabase m => Int -> m (Maybe Int)
|
|
newestLTSMajor x =
|
|
run $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]
|
|
|
|
newestNightly :: GetStackageDatabase m => m (Maybe Day)
|
|
newestNightly =
|
|
run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]
|
|
|
|
lookupSnapshot :: GetStackageDatabase m => SnapName -> m (Maybe (Entity Snapshot))
|
|
lookupSnapshot name = run $ 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
|
|
, pliIsCore :: !Bool
|
|
}
|
|
|
|
getPackages :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo]
|
|
getPackages sid = liftM (map toPLI) $ run $ 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
|
|
, sp E.^. SnapshotPackageIsCore
|
|
)
|
|
where
|
|
toPLI (E.Value name, E.Value synopsis, E.Value version, E.Value isCore) = PackageListingInfo
|
|
{ pliName = name
|
|
, pliVersion = version
|
|
, pliSynopsis = synopsis
|
|
, pliIsCore = isCore
|
|
}
|
|
|
|
data ModuleListingInfo = ModuleListingInfo
|
|
{ mliName :: !Text
|
|
, mliPackageVersion :: !Text
|
|
}
|
|
|
|
getSnapshotModules
|
|
:: GetStackageDatabase m
|
|
=> SnapshotId
|
|
-> m [ModuleListingInfo]
|
|
getSnapshotModules sid = liftM (map toMLI) $ run $ do
|
|
E.select $ E.from $ \(p,sp,m) -> do
|
|
E.where_ $
|
|
(p E.^. PackageId E.==. sp E.^. SnapshotPackagePackage) E.&&.
|
|
(sp E.^. SnapshotPackageSnapshot E.==. E.val sid) E.&&.
|
|
(m E.^. ModulePackage E.==. sp E.^. SnapshotPackageId)
|
|
E.orderBy
|
|
[ E.asc $ m E.^. ModuleName
|
|
, E.asc $ p E.^. PackageName
|
|
]
|
|
return
|
|
( m E.^. ModuleName
|
|
, p E.^. PackageName
|
|
, sp E.^. SnapshotPackageVersion
|
|
)
|
|
where
|
|
toMLI (E.Value name, E.Value pkg, E.Value version) = ModuleListingInfo
|
|
{ mliName = name
|
|
, mliPackageVersion = concat [pkg, "-", version]
|
|
}
|