From 39f60ec4c3a7f2b295d4abb392ba2ff43b659460 Mon Sep 17 00:00:00 2001 From: "Boris M. Yartsev" Date: Sat, 1 Jul 2017 15:49:12 +0300 Subject: [PATCH] Added ltsupdatepersist and ltsquerypersist commands, that update the persistent archive of stackage files and allow to query it --- REPL/.gitignore | 1 + REPL/src/Common.hs | 5 +++ REPL/src/HackageArchive.hs | 17 ++++------ REPL/src/HackageCommands.hs | 3 +- REPL/src/REPL.hs | 30 ++++++++-------- REPL/src/StackageArchive.hs | 66 +++++++++++++++++++++++++++++++----- REPL/src/StackageCommands.hs | 27 ++++++++++++--- 7 files changed, 110 insertions(+), 39 deletions(-) diff --git a/REPL/.gitignore b/REPL/.gitignore index 593f1ad..86d4618 100644 --- a/REPL/.gitignore +++ b/REPL/.gitignore @@ -1,2 +1,3 @@ arch/ hackagefiles/ +stackagefiles/ diff --git a/REPL/src/Common.hs b/REPL/src/Common.hs index 73a8470..3a06879 100644 --- a/REPL/src/Common.hs +++ b/REPL/src/Common.hs @@ -23,6 +23,7 @@ module Common(URL, getLTSFilesDir, getLTSStackageURL, getLTSFile, + getLTSPersistDir, StackageSnapshot, StackageSnapshots(..), getNormalSnapshots, @@ -101,6 +102,7 @@ tarClone = "01-index.orig.tar" getArchivePersistDir :: HackageUpdateInfo -> FilePath getArchivePersistDir iuh = iuhUpdateDir iuh "persist" + getArchive :: HackageUpdateInfo -> FilePath getArchive iuh = iuhUpdateDir iuh archive @@ -171,6 +173,9 @@ data StackageUpdateInfo = SUI { suiLTSURL :: URL } deriving (Eq, Show) +getLTSPersistDir :: StackageUpdateInfo -> FilePath +getLTSPersistDir sui = suiUpdateDir sui "persist" + defaultSUI :: StackageUpdateInfo defaultSUI = SUI { suiUpdateDir = "stackagefiles", diff --git a/REPL/src/HackageArchive.hs b/REPL/src/HackageArchive.hs index abeca44..a6a77f2 100644 --- a/REPL/src/HackageArchive.hs +++ b/REPL/src/HackageArchive.hs @@ -13,7 +13,6 @@ module HackageArchive ( queryPersistentMap, HackagePackage (..), - HackageName, HackageMap, HackageUpdateMap, HackageUpdate, @@ -50,12 +49,10 @@ import qualified Control.Monad.State as State import System.FilePath.Posix(hasTrailingPathSeparator) import Common -type HackageName = String - -- The record for each of the package from hackage -- TODO - add another information about the packages data HackagePackage = HP { - name :: HackageName, + name :: PackageName, pVersion :: DV.Version, author :: String } deriving (Eq, Show) @@ -65,11 +62,11 @@ data HackageUpdate = Added | Removed | Updated deriving (Eq, Show) -- The map of all the hackage packages with name as the key and HackagePackage -- as the value -type HackageMap = M.Map HackageName HackagePackage -type PreHackageMap = M.Map HackageName DV.Version +type HackageMap = M.Map PackageName HackagePackage +type PreHackageMap = M.Map PackageName DV.Version -- The map, that shows, which packages have change since the last update -type HackageUpdateMap = M.Map HackageName (HackageUpdate, HackagePackage) +type HackageUpdateMap = M.Map PackageName (HackageUpdate, HackagePackage) -- Parses the file path of the cabal file to get version and package name parseCabalFilePath :: RP.ReadP PackageData @@ -164,7 +161,7 @@ $(deriveSafeCopy 0 'base ''HackagePackage) $(deriveSafeCopy 0 'base ''KeyValue) $(deriveSafeCopy 0 'base ''HackageUpdate) -insertKey :: HackageName -> HackagePackage -> Update KeyValue () +insertKey :: PackageName -> HackagePackage -> Update KeyValue () insertKey key value = do KeyValue hackageMap <- State.get State.put (KeyValue (M.insert key value hackageMap)) @@ -172,7 +169,7 @@ insertKey key value = do updateMap :: HackageMap -> Update KeyValue () updateMap newMap = State.put (KeyValue newMap) -lookupKey :: HackageName -> Query KeyValue (Maybe HackagePackage) +lookupKey :: PackageName -> Query KeyValue (Maybe HackagePackage) lookupKey key = do KeyValue m <- ask return (M.lookup key m) @@ -202,7 +199,7 @@ printPersistentDiffMap path newMap = do mapM_ (print.snd) $ M.toList diffMap closeAcidState acid -queryPersistentMap :: FilePath -> HackageName -> IO (Maybe HackagePackage) +queryPersistentMap :: FilePath -> PackageName -> IO (Maybe HackagePackage) queryPersistentMap path name = do acid <- openLocalStateFrom path (KeyValue M.empty) val <- query acid (LookupKey name) diff --git a/REPL/src/HackageCommands.hs b/REPL/src/HackageCommands.hs index 5c64521..61caa87 100644 --- a/REPL/src/HackageCommands.hs +++ b/REPL/src/HackageCommands.hs @@ -133,8 +133,7 @@ updatePersistentFromTar updateDir tarFile = do let newMap = buildHackageMap newTar (buildPreHackageMap newTar) updatePersistentMap updateDir newMap - -showPersistentQuery :: FilePath -> HackageName -> IO() +showPersistentQuery :: FilePath -> PackageName -> IO() showPersistentQuery updateDir name = do putStrLn $ "Querying storage hackage map with " ++ name value <- queryPersistentMap updateDir name diff --git a/REPL/src/REPL.hs b/REPL/src/REPL.hs index 71e7732..dac2d1c 100644 --- a/REPL/src/REPL.hs +++ b/REPL/src/REPL.hs @@ -15,7 +15,6 @@ import Network.HTTP.Client(HttpException) import Common import qualified HackageCommands as HC import qualified StackageCommands as SC ---import qualified HttpDownload as HD processREPLCycle :: UpdateInfo -> IO () processREPLCycle ui = forever $ do @@ -61,22 +60,23 @@ buildCommand ui = processCommand | chk "querypersist" = HC.showPersistentQuery ud (parseValEnd command) -- shows the snapshots from stackage - | chk "snapshots" = SC.showSnapshots snapshotsURL - + | chk "ltssnapshots" = SC.showSnapshots snapshotsURL + -- gets all the lts snapshots from the stackage, updates the lts files according to them + | chk "ltsallupdate" = + SC.updateAllLTSFiles ltsFileDir ltsURL snapshotsURL + -- shows contents of the lts file + | chk "ltsshowcont" = let lts = parseValEnd command in + SC.showLTSContents (getLTSFile (sui ui) lts) + | chk "ltsshowmap" = SC.showStackageMapContents ltsFileDir ltsURL snapshotsURL 20 + -- gets all the lts snapshots from the stackage, updates the lts files according to them + -- and then updates the persistent storage + | chk "ltsupdatepersist" = SC.updatePersistentMapFromLTS sud ltsFileDir ltsURL snapshotsURL + -- queries the persistent map of the stackage packages + | chk "ltsquerypersist" = SC.showPersistentQuery sud (parseValEnd command) + -- updates the specified lts package from github | chk "ltsupdate" = let lts = parseValEnd command in SC.updateLTSFile (getLTSFile (sui ui) lts) (getLTSGithubURL (sui ui) lts) - | chk "ltsallupdate" = - SC.updateAllLTSFiles ltsFileDir ltsURL snapshotsURL - - | chk "ltsshowcont" = let lts = parseValEnd command in - SC.showLTSContents (getLTSFile (sui ui) lts) - - | chk "ltsshowmap" = SC.showStackageMapContents ltsFileDir ltsURL snapshotsURL 20 - - -- | chk "ltspersist" = - -- SC.updateLT - -- exits the REPL | chk "exit" = exitREPL | chk "quit" = exitREPL @@ -121,6 +121,8 @@ buildCommand ui = processCommand persistCommand = HC.updatePersistentFromTar ud trFile ltsFileDir = getLTSFilesDir (sui ui) ltsURL = suiLTSURL (sui ui) + sud = (getLTSPersistDir.sui) ui + showHelp :: UpdateInfo -> IO() diff --git a/REPL/src/StackageArchive.hs b/REPL/src/StackageArchive.hs index 6641658..1d82a31 100644 --- a/REPL/src/StackageArchive.hs +++ b/REPL/src/StackageArchive.hs @@ -3,8 +3,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} -module StackageArchive( - generateStackageMap +module StackageArchive( + generateStackageMap, + updatePersistentMap, + queryPersistentMap, + StackagePackage(..), + StackageMap ) where import qualified Data.Map.Strict as M @@ -12,12 +16,17 @@ import qualified Data.Version as DV import qualified Data.ByteString as BS import System.FilePath(()) +import Data.Typeable +import Data.Acid +import Data.Acid.Advanced +import Data.SafeCopy +import qualified Control.Monad.State as State +import Control.Monad.Reader + + import Common import StackageUpdate --- The name of the package, that is present somewhere in the stackage -type StackageName = String - -- This is a mapping of version of the package, that is present in the lts -- snapshot with the specified name. So newtype StackageVersionLTS = SVL (M.Map LongSnapshotName DV.Version) deriving (Eq) @@ -29,7 +38,7 @@ makeSVL :: LongSnapshotName -> DV.Version -> StackageVersionLTS makeSVL ss v = SVL $ M.singleton ss v data StackagePackage = SP { - name :: StackageName, + name :: PackageName, ltsVersions :: StackageVersionLTS } deriving (Eq) @@ -39,7 +48,7 @@ instance Show StackagePackage where addSVL :: StackagePackage -> LongSnapshotName -> DV.Version -> StackagePackage addSVL (SP n (SVL m)) name version = SP n $ SVL $ M.insert name version m -type StackageMap = M.Map StackageName StackagePackage +type StackageMap = M.Map PackageName StackagePackage updateStackageMap :: StackageMap -> LongSnapshotName -> PackageDatum -> StackageMap updateStackageMap map snapshotName (PD packages) = @@ -57,7 +66,48 @@ generateStackageMap :: FilePath -> StackageSnapshots -> IO StackageMap -- make the empty map here generateStackageMap _ (SSS []) = return M.empty generateStackageMap filePath (SSS (s: xs)) = do + -- get the yaml file body <- BS.readFile (filePath longName s ++ ".yaml") newMap <- generateStackageMap filePath $ SSS xs + -- build the map from this yaml file pkgDatum <- parseYamlFileThrow body - return $ updateStackageMap newMap (longName s) pkgDatum \ No newline at end of file + return $ updateStackageMap newMap (longName s) pkgDatum + +-- this is needed for acid serialization +newtype KeyValue = KeyValue StackageMap deriving (Typeable) + +$(deriveSafeCopy 0 'base ''StackageVersionLTS) +$(deriveSafeCopy 0 'base ''StackagePackage) +$(deriveSafeCopy 0 'base ''DV.Version) +$(deriveSafeCopy 0 'base ''KeyValue) + + +insertKey :: PackageName -> StackagePackage -> Update KeyValue () +insertKey key value = do + KeyValue stackageMap <- State.get + State.put (KeyValue (M.insert key value stackageMap)) + +updateMap :: StackageMap -> Update KeyValue () +updateMap newMap = State.put (KeyValue newMap) + +lookupKey :: PackageName -> Query KeyValue (Maybe StackagePackage) +lookupKey key = do + KeyValue m <- ask + return (M.lookup key m) + +$(makeAcidic ''KeyValue ['insertKey, 'lookupKey, 'updateMap]) + +updatePersistentMap :: FilePath -> StackageMap -> IO () +updatePersistentMap path newMap = do + acid <- openLocalStateFrom path (KeyValue M.empty) + do + putStrLn "Updating the persistent map" + update acid (UpdateMap newMap) + closeAcidState acid + +queryPersistentMap :: FilePath -> PackageName -> IO (Maybe StackagePackage) +queryPersistentMap path name = do + acid <- openLocalStateFrom path (KeyValue M.empty) + val <- query acid (LookupKey name) + closeAcidState acid + return val diff --git a/REPL/src/StackageCommands.hs b/REPL/src/StackageCommands.hs index a19007f..0458af6 100644 --- a/REPL/src/StackageCommands.hs +++ b/REPL/src/StackageCommands.hs @@ -2,9 +2,10 @@ module StackageCommands( showSnapshots, showLTSContents, showStackageMapContents, + showPersistentQuery, updateLTSFile, updateAllLTSFiles, - updatePersistentFromLTS) where + updatePersistentMapFromLTS) where import qualified Data.ByteString as BS import qualified Data.Map.Strict as M @@ -31,15 +32,11 @@ updateLTSFile :: FilePath -> URL -> IO () updateLTSFile = fetchLTS -- updates all of the lts files from the snapshot file at stackage - updateAllLTSFiles :: FilePath -> URL -> URL -> IO () updateAllLTSFiles ltsDir ltsURL snapshotsURL = do snapshots <- fetchStackageSnapshots snapshotsURL fetchAllLTSFiles ltsDir ltsURL (filterNormal snapshots) -updatePersistentFromLTS :: FilePath -> FilePath -> IO() -updatePersistentFromLTS updateDir ltsDir = undefined - showStackageMapContents :: FilePath -> URL -> URL -> Int -> IO() showStackageMapContents ltsDir ltsURL snapshotsURL count = do putStrLn "Fetching snapshot lists" @@ -50,3 +47,23 @@ showStackageMapContents ltsDir ltsURL snapshotsURL count = do map <- generateStackageMap ltsDir (filterNormal snapshots) putStrLn $ "Printing " ++ show count ++ " packages" mapM_ print $ take count $ M.toList map + +updatePersistentMapFromLTS :: FilePath -> FilePath -> URL -> URL -> IO() +updatePersistentMapFromLTS updateDir ltsDir ltsURL snapshotsURL = do + putStrLn "Fetching snapshot lists" + snapshots <- fetchStackageSnapshots snapshotsURL + putStrLn "Downloading YAML files" + fetchAllLTSFiles ltsDir ltsURL (filterNormal snapshots) + putStrLn "Generating stackage map" + map <- generateStackageMap ltsDir (filterNormal snapshots) + updatePersistentMap updateDir map + +showPersistentQuery :: FilePath -> PackageName -> IO() +showPersistentQuery updateDir name = do + putStrLn $ "Querying storage stackage map with " ++ name + value <- queryPersistentMap updateDir name + case value of + Just package -> do + putStrLn "Found" + print package + Nothing -> putStrLn "Not found"