From 29f879962ec069565a5cd023727c25374e628c60 Mon Sep 17 00:00:00 2001 From: "Boris M. Yartsev" Date: Tue, 4 Jul 2017 21:24:21 +0300 Subject: [PATCH] Made almost nice REPL and module for hackage and stackage lookup and update --- REPL/app/Main.hs | 9 +- REPL/index-project.cabal | 10 +- REPL/src/AllCommands.hs | 103 +++++++++---- REPL/src/Common.hs | 110 +------------- REPL/src/HackageCommands.hs | 271 +++++++++++++++++++++++++++++++---- REPL/src/IndexProject.hs | 12 -- REPL/src/PackageManager.hs | 17 +++ REPL/src/REPL.hs | 246 +++++++++++++------------------ REPL/src/StackageArchive.hs | 1 - REPL/src/StackageCommands.hs | 128 ++++++++++++++++- REPL/test/Spec.hs | 6 +- 11 files changed, 576 insertions(+), 337 deletions(-) delete mode 100644 REPL/src/IndexProject.hs create mode 100644 REPL/src/PackageManager.hs diff --git a/REPL/app/Main.hs b/REPL/app/Main.hs index a2ee8b5..236c3f3 100644 --- a/REPL/app/Main.hs +++ b/REPL/app/Main.hs @@ -4,7 +4,12 @@ module Main where import Data.Default -import IndexProject +import REPL +import qualified AllCommands as AC +import PackageManager main :: IO () -main = processREPLCycle def +-- launches package manager update, that performs update every 60 minutes +--main = launchPackageUpdater def 60 +-- launches REPL for hackage and stackage +main = processREPLCycle def AC.allCommands diff --git a/REPL/index-project.cabal b/REPL/index-project.cabal index c6d5e42..094c41c 100644 --- a/REPL/index-project.cabal +++ b/REPL/index-project.cabal @@ -15,9 +15,15 @@ cabal-version: >=1.10 library hs-source-dirs: src - other-modules: Common, FileUtils, HttpDownload, HackageUpdate, REPL, StackageUpdate + other-modules: FileUtils, HttpDownload, HackageUpdate, StackageUpdate - exposed-modules: IndexProject, HackageArchive, StackageArchive, HackageCommands, StackageCommands, AllCommands + exposed-modules: Common + , REPL + , HackageArchive, StackageArchive + , HackageCommands, StackageCommands + , AllCommands + , PackageManager + build-depends: base >= 4.7 && < 5 , directory , containers diff --git a/REPL/src/AllCommands.hs b/REPL/src/AllCommands.hs index 52a710f..9618cb8 100644 --- a/REPL/src/AllCommands.hs +++ b/REPL/src/AllCommands.hs @@ -1,42 +1,89 @@ -module AllCommands(totalUpdate) where +module AllCommands( + UpdateInfo(..), + CombinedPackage (..), + queryCombinedData, + allCommands, updateAllCommand) where + +import Data.Default import Common import qualified HackageCommands as HC import qualified StackageCommands as SC import qualified HackageArchive as HA +import qualified StackageArchive as SA +import REPL -totalUpdate :: UpdateInfo -> IO() -totalUpdate ui = do - putStrLn "Total update of a system!" +data UpdateInfo = UI { + iuh :: HC.HackageUpdateInfo, + sui :: SC.StackageUpdateInfo +} deriving (Eq, Show) - putStrLn "Stackage update..." - SC.updatePersistentMapFromLTS sud ltsFileDir ltsURL snapshotsURL +instance Default UpdateInfo where + def = defaultUI - putStrLn "Hackage update..." - HC.updateTotalArchive updateCommand unzipCommand persistCommand +defaultUI :: UpdateInfo +defaultUI = UI { + iuh = def, + sui = def +} - where - sud = (getLTSPersistDir.sui) ui - ltsFileDir = getLTSFilesDir (sui ui) - ltsURL = suiLTSURL (sui ui) - snapshotsURL = (getSnapshotURL.sui) ui +newtype CombinedPackage = CP (HA.HackagePackage, Maybe SA.StackagePackage) deriving (Eq) - arch = (getArchive.iuh) ui - archURL = (iuhArchiveURL.iuh) ui - snapURL = (iuhSnapshotURL.iuh) ui - trFile = (getTar.iuh) ui - ud = (getArchivePersistDir.iuh) ui +instance Show CombinedPackage where + show (CP (hp, Just sp)) = HA.name hp ++ " " ++ show (HA.pVersion hp) ++ " present in stackage" + show (CP (hp, Nothing)) = HA.name hp ++ " " ++ show (HA.pVersion hp) ++ " not in stackage" - updateCommand = HC.updateArchive snapURL archURL arch - unzipCommand = HC.unzipArchive arch trFile - persistCommand = HC.updatePersistentFromTar ud trFile -{- -queryCombinedData :: UpdateInfo -> PackageName -> IO() + +queryCombinedData :: UpdateInfo -> PackageName -> IO (Maybe CombinedPackage) queryCombinedData ui package = do - value <- HA.queryPersistentMap hUpdateDir package - return () + hp <- HA.queryPersistentMap hUpdateDir package + sp <- SA.queryPersistentMap sUpdateDir package + return $ hp >>= \p -> Just $ CP (p, sp) where - sUpdateDir = (getLTSPersistDir.sui) ui - hUpdateDir = (getArchivePersistDir.iuh) ui + sUpdateDir = (SC.getLTSPersistDir.sui) ui + hUpdateDir = (HC.getArchivePersistDir.iuh) ui --} \ No newline at end of file + +-- This method just shows the result of querying by queryCombinedData method +showQueryCombinedData :: UpdateInfo -> PackageName -> IO () +showQueryCombinedData ui package = do + putStrLn $ "Querying package " ++ package + query <- queryCombinedData ui package + print query + +showQueryCombinedDataCommand :: REPLCommand UpdateInfo +showQueryCombinedDataCommand = RC { + cTag = "all", + cMatch = isPrefixCommand "query", + cExec = \ui commandStr -> let package = parseValEnd commandStr in showQueryCombinedData ui package, + cDescription = const "query package - queries package in stackage and hackage archives" +} + +updateAllCommand :: REPLCommand UpdateInfo +updateAllCommand = RC { + cTag = "all", + cMatch = isTrimCommand "allupdate", + cExec = \ui _ -> cExec SC.updatePersistentMapFromLTSCommand (sui ui) "" >> + cExec HC.updateAllHackageCommand (iuh ui) "", + cDescription = const "allupdate - updates stackage and hackage" +} + +transformH :: REPLCommand HC.HackageUpdateInfo -> REPLCommand UpdateInfo +transformH hCommand = RC { + cTag = cTag hCommand, -- same as in the hackage command + cMatch = cMatch hCommand, + cExec = \ui commandStr -> cExec hCommand (iuh ui) commandStr, + cDescription = cDescription hCommand . iuh +} + +transformS :: REPLCommand SC.StackageUpdateInfo -> REPLCommand UpdateInfo +transformS sCommand = RC { + cTag = cTag sCommand, -- same as in the hackage command + cMatch = cMatch sCommand, + cExec = \ui commandStr -> cExec sCommand (sui ui) commandStr, + cDescription = cDescription sCommand . sui +} + +allCommands :: [REPLCommand UpdateInfo] +allCommands = updateAllCommand : showQueryCombinedDataCommand : + map transformH HC.hackageCommands ++ map transformS SC.stackageCommands \ No newline at end of file diff --git a/REPL/src/Common.hs b/REPL/src/Common.hs index 3a06879..f77bc30 100644 --- a/REPL/src/Common.hs +++ b/REPL/src/Common.hs @@ -4,13 +4,6 @@ module Common(URL, PackageDatum(..), SnapshotData(..), UpdateArchiveException(..), - UpdateInfo(..), - HackageUpdateInfo(..), - getArchive, - getArchiveClone, - getTar, - getArchivePersistDir, - getTarClone, parseIntEnd, parseValEnd, @@ -18,18 +11,11 @@ module Common(URL, LongSnapshotName, shortName, longName, - getSnapshotURL, - getLTSGithubURL, - getLTSFilesDir, - getLTSStackageURL, - getLTSFile, - getLTSPersistDir, StackageSnapshot, StackageSnapshots(..), getNormalSnapshots, filterNormal, - StackageLTS, - StackageUpdateInfo(..)) where + StackageLTS) where import qualified Control.Exception as X import qualified Data.ByteString.Lazy as BL @@ -38,27 +24,10 @@ import qualified Data.List as DL import Data.Version as DV import Data.Int(Int64) -import Data.Default -import System.FilePath(()) - type URL = String type PackageName = String type PackageData = (PackageName, DV.Version) -data UpdateInfo = UI { - iuh :: HackageUpdateInfo, - sui :: StackageUpdateInfo -} deriving (Eq, Show) - -instance Default UpdateInfo where - def = defaultUI - -defaultUI :: UpdateInfo -defaultUI = UI { - iuh = defaultIUH, - sui = defaultSUI -} - data SnapshotData = SnapshotData { md5Hash :: String, lengthFile :: Int64 @@ -70,50 +39,6 @@ newtype UpdateArchiveException = UAE String deriving (Show, Eq) instance X.Exception UpdateArchiveException -- the constructor short name is really awkward in russian -data HackageUpdateInfo = IUH { - iuhUpdateDir :: FilePath, - iuhSnapshotURL :: URL, - iuhArchiveURL :: URL -} deriving (Eq, Show) - - -instance Default HackageUpdateInfo where - def = defaultIUH - -defaultIUH :: HackageUpdateInfo -defaultIUH = IUH { - iuhUpdateDir = "hackagefiles", - iuhSnapshotURL = "https://hackage.haskell.org/snapshot.json", - iuhArchiveURL = "https://hackage.haskell.org/01-index.tar.gz" -} - -archive :: FilePath -archive = "01-index.tar.gz" - -archiveClone :: FilePath -archiveClone = "01-index.tar.gz.orig" - -tar :: FilePath -tar = "01-index.tar" - -tarClone :: FilePath -tarClone = "01-index.orig.tar" - -getArchivePersistDir :: HackageUpdateInfo -> FilePath -getArchivePersistDir iuh = iuhUpdateDir iuh "persist" - - -getArchive :: HackageUpdateInfo -> FilePath -getArchive iuh = iuhUpdateDir iuh archive - -getArchiveClone :: HackageUpdateInfo -> FilePath -getArchiveClone iuh = iuhUpdateDir iuh archiveClone - -getTar :: HackageUpdateInfo -> FilePath -getTar iuh = iuhUpdateDir iuh tar - -getTarClone :: HackageUpdateInfo -> FilePath -getTarClone iuh = iuhUpdateDir iuh tarClone parseIntEnd :: (Num a, Read a) => String -> a @@ -150,35 +75,4 @@ shortName = fst longName :: StackageSnapshot -> String longName = snd -type StackageLTS = (LongSnapshotName, [PackageData]) - -getLTSStackageURL :: StackageUpdateInfo -> LongSnapshotName -> URL -getLTSStackageURL sui name = suiStackageURL sui name "cabal.config" - -getSnapshotURL :: StackageUpdateInfo -> URL -getSnapshotURL sui = suiStackageURL sui "download/lts-snapshots.json" - -getLTSGithubURL :: StackageUpdateInfo -> LongSnapshotName -> URL -getLTSGithubURL sui name = suiLTSURL sui (name ++ ".yaml") - -getLTSFilesDir :: StackageUpdateInfo -> FilePath -getLTSFilesDir sui = suiUpdateDir sui "ltsfiles" - -getLTSFile :: StackageUpdateInfo -> String -> FilePath -getLTSFile sui lts = getLTSFilesDir sui (lts ++ ".yaml") - -data StackageUpdateInfo = SUI { - suiUpdateDir :: FilePath, - suiStackageURL :: URL, - suiLTSURL :: URL -} deriving (Eq, Show) - -getLTSPersistDir :: StackageUpdateInfo -> FilePath -getLTSPersistDir sui = suiUpdateDir sui "persist" - -defaultSUI :: StackageUpdateInfo -defaultSUI = SUI { - suiUpdateDir = "stackagefiles", - suiStackageURL = "https://www.stackage.org/", - suiLTSURL = "https://raw.githubusercontent.com/fpco/lts-haskell/master/" -} \ No newline at end of file +type StackageLTS = (LongSnapshotName, [PackageData]) \ No newline at end of file diff --git a/REPL/src/HackageCommands.hs b/REPL/src/HackageCommands.hs index 2716bab..e833220 100644 --- a/REPL/src/HackageCommands.hs +++ b/REPL/src/HackageCommands.hs @@ -1,33 +1,81 @@ module HackageCommands( - showTarElements, - showTarPreElements, - showFileSnapshot, - showFileSubstring, - showUpdateData, - copyArchive, - showDiffMap, - cutFile, - unzipArchive, - removeArchiveFiles, - showArchiveCompare, - updateArchive, - updateArchiveVoid, - updateTotalArchive, - - updatePersistentFromTar, - showPersistentQuery, - showPersistentTarCompare - ) where + hackageCommands, + updateAllHackageCommand, + HackageUpdateInfo(..), + getArchive, + getArchiveClone, + getTar, + getArchivePersistDir, + getTarClone, + defaultIUH) where import qualified Data.Map.Strict as M import Data.Int(Int64) import System.Directory(copyFile) import Control.Monad(void) +import Data.Default +import System.FilePath(()) import FileUtils import Common import HackageArchive import HackageUpdate +import REPL + +data HackageUpdateInfo = IUH { + iuhUpdateDir :: FilePath, + iuhSnapshotURL :: URL, + iuhArchiveURL :: URL +} deriving (Eq, Show) + +instance Default HackageUpdateInfo where + def = defaultIUH + +hackageCommands :: [REPLCommand HackageUpdateInfo] +hackageCommands = [ + showTarElementsCommand, + showTarPreElementsCommand, + showArchiveSnapshotCommand, + showArchiveSnapshotCloneCommand, + showUpdateArchiveCommand, + showUpdateArchiveCloneCommand, + unzipArchiveCommand, + unzipArchiveCloneCommand, + copyArchiveCommand, + showDiffMapCommand, + cutArchiveCommand, + cutArchiveCloneCommand, + removeArchiveFilesCommand, + removeArchiveFilesCloneCommand, + archiveCompareCommand, + updateArchiveCommand, + updatePersistentFromArchiveCommand, + showPersistentQueryCommand, + showPersistentTarCompareCommand, + updateAllHackageCommand + ] + +defaultIUH :: HackageUpdateInfo +defaultIUH = IUH { + iuhUpdateDir = "hackagefiles", + iuhSnapshotURL = "https://hackage.haskell.org/snapshot.json", + iuhArchiveURL = "https://hackage.haskell.org/01-index.tar.gz" +} + +getArchivePersistDir :: HackageUpdateInfo -> FilePath +getArchivePersistDir iuh = iuhUpdateDir iuh "persist" + +getArchive :: HackageUpdateInfo -> FilePath +getArchive iuh = iuhUpdateDir iuh "01-index.tar.gz" + +getArchiveClone :: HackageUpdateInfo -> FilePath +getArchiveClone iuh = iuhUpdateDir iuh "01-index.tar.gz.orig" + +getTar :: HackageUpdateInfo -> FilePath +getTar iuh = iuhUpdateDir iuh "01-index.tar" + +getTarClone :: HackageUpdateInfo -> FilePath +getTarClone iuh = iuhUpdateDir iuh "01-index.orig.tar" -- shows the first count elements, parsed from the tar archive showTarElements :: FilePath -> Int -> IO () @@ -36,6 +84,14 @@ showTarElements path count = do tar <- loadTar path mapM_ (print.snd) $ take count $ M.toList $ buildHackageMap tar (buildPreHackageMap tar) +showTarElementsCommand :: REPLCommand HackageUpdateInfo +showTarElementsCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "tarshow", + cExec = \iuh _ -> showTarElements (getTar iuh) 50, + cDescription = \iuh -> "tarshow - loads the map of entries from " ++ getTar iuh ++ " and displays it" +} + -- shows the first count pre elements (only path is parsed) form the tar archive showTarPreElements :: FilePath -> Int -> IO () showTarPreElements path count = do @@ -43,6 +99,15 @@ showTarPreElements path count = do tar <- loadTar path mapM_ print $ take count $ M.toList $ buildPreHackageMap tar +showTarPreElementsCommand :: REPLCommand HackageUpdateInfo +showTarPreElementsCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "tarshowpre", + cExec = \iuh _ -> showTarPreElements (getTar iuh) 50, + cDescription = \iuh -> "tarshowpre - loads the premap of entries from " ++ + getTar iuh ++ " and displays it" +} + -- Displays the snapshot of the file showFileSnapshot :: FilePath -> IO() showFileSnapshot file = do @@ -50,6 +115,22 @@ showFileSnapshot file = do putStrLn $ "File result for " ++ file putStrLn $ "\tFile snapshot: " ++ show filesnapshot +showArchiveSnapshotCommand :: REPLCommand HackageUpdateInfo +showArchiveSnapshotCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "archivesnapshot", + cExec = \iuh _ -> showFileSnapshot (getArchive iuh), + cDescription = \iuh -> "archivesnapshot - displays the current " ++ getArchive iuh ++ " length and md5 hash" +} + +showArchiveSnapshotCloneCommand :: REPLCommand HackageUpdateInfo +showArchiveSnapshotCloneCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-archivesnapshot", + cExec = \iuh _ -> showFileSnapshot (getArchiveClone iuh), + cDescription = \iuh -> "system-archivesnapshot - displays the current " ++ + getArchiveClone iuh ++ " length and md5 hash" +} -- Shows the update data for the archive on disk showUpdateData :: FilePath -> URL -> IO() @@ -60,6 +141,25 @@ showUpdateData file json = do putStrLn $ "\tFile snapshot: " ++ show filesnapshot putStrLn $ "\tRange to update: " ++ show range +-- checks the current hackage gzip archive and understands what to download +showUpdateArchiveCommand :: REPLCommand HackageUpdateInfo +showUpdateArchiveCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "check", + cExec = \iuh _ -> showUpdateData (getArchive iuh) (iuhSnapshotURL iuh), + cDescription = \iuh -> "check - downloads the json length and md5 hash from " ++ + iuhSnapshotURL iuh ++ ", and compares it with local " ++ getArchive iuh +} + +showUpdateArchiveCloneCommand :: REPLCommand HackageUpdateInfo +showUpdateArchiveCloneCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-checkclone", + cExec = \iuh _ -> showUpdateData (getArchive iuh) (iuhSnapshotURL iuh), + cDescription = \iuh -> "system-checkclone - downloads the json length and md5 hash from " ++ + iuhSnapshotURL iuh ++ ", and compares it with local " ++ getArchiveClone iuh +} + -- shows the substring of specified length from file from offset showFileSubstring :: FilePath -> Int64 -> Int64 -> IO () showFileSubstring file from length = do @@ -74,6 +174,15 @@ copyArchive archive1 archive2 = do copyFile archive1 archive2 putStrLn $ "Copied the " ++ archive1 ++ " to " ++ archive2 +copyArchiveCommand :: REPLCommand HackageUpdateInfo +copyArchiveCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-copyorig", + cExec = \iuh _ -> copyArchive (getArchive iuh) (getArchiveClone iuh), + cDescription = \iuh -> "system-copyorig - copy the " ++ getArchive iuh ++ + " to " ++ getArchiveClone iuh +} + -- Shows the difference between two tar archives, by building the pre maps of -- each of them, and then comparing showDiffMap :: FilePath -> FilePath -> IO () @@ -86,7 +195,14 @@ showDiffMap newTarFile oldTarFile = do let diffMap = buildDifferenceMap oldMap newMap mapM_ (print.snd) $ M.toList diffMap - +showDiffMapCommand :: REPLCommand HackageUpdateInfo +showDiffMapCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-tarcmp", + cExec = \iuh _ -> showDiffMap (getTar iuh) (getTarClone iuh), + cDescription = \iuh -> "system-tarcmp - compares the entries of " ++ + getTar iuh ++ " and " ++ getTarClone iuh +} -- this method cuts the data from the end of the archive, -- because hackage 01-index.tar.gz is not strictly incremental cutFile :: FilePath -> Int64 -> IO() @@ -94,12 +210,47 @@ cutFile path size = do truncateIfExists path size putStrLn $ "Cut " ++ show size ++ " bytes from " ++ path +cutArchiveCommand :: REPLCommand HackageUpdateInfo +cutArchiveCommand = RC { + cTag = "hackage", + cMatch = isPrefixCommand "cut ", + cExec = \iuh command -> cutFile (getArchive iuh) (parseIntEnd command), + cDescription = \iuh -> "cut size - cuts the size bytes from the end of the " ++ + getArchive iuh ++ ", for update command" +} + +cutArchiveCloneCommand :: REPLCommand HackageUpdateInfo +cutArchiveCloneCommand = RC { + cTag = "system", + cMatch = isPrefixCommand "system-cutclone ", + cExec = \iuh command -> cutFile (getArchiveClone iuh) (parseIntEnd command), + cDescription = \iuh -> "system-cutclone size - cuts the size bytes from the end of the " ++ + getArchiveClone iuh ++ ", for update command" +} + -- Unzips the gz archive to tar unzipArchive :: FilePath -> FilePath -> IO() unzipArchive archive tar = do putStrLn $ "Unzipping " ++ archive ++ " to " ++ tar unzipFile archive tar +unzipArchiveCommand :: REPLCommand HackageUpdateInfo +unzipArchiveCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "unzip", + cExec = \iuh _ -> unzipArchive (getArchive iuh) (getTar iuh), + cDescription = \iuh -> "unzip - unzips the " ++ getArchive iuh ++ " in the " ++ getTar iuh ++ " file" +} + +unzipArchiveCloneCommand :: REPLCommand HackageUpdateInfo +unzipArchiveCloneCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-unzipclone", + cExec = \iuh _ -> unzipArchive (getArchiveClone iuh) (getTarClone iuh), + cDescription = \iuh -> "system-unzipclone - unzips the " ++ getArchiveClone iuh ++ " in the " ++ + getTarClone iuh ++ " file" +} + -- Removes gz and tar files removeArchiveFiles :: FilePath -> FilePath -> IO() removeArchiveFiles archive tar = do @@ -107,25 +258,49 @@ removeArchiveFiles archive tar = do removeIfExists archive removeIfExists tar +removeArchiveFilesCommand :: REPLCommand HackageUpdateInfo +removeArchiveFilesCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "clean", + cExec = \iuh _ -> removeArchiveFiles (getArchive iuh) (getTar iuh), + cDescription = \iuh -> "clean - deletes the " ++ getArchive iuh ++ " and " ++ getTar iuh +} + +removeArchiveFilesCloneCommand :: REPLCommand HackageUpdateInfo +removeArchiveFilesCloneCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-cleanclone", + cExec = \iuh _ -> removeArchiveFiles (getArchiveClone iuh) (getTarClone iuh), + cDescription = \iuh -> "system-cleanclone - deletes the " ++ + getArchiveClone iuh ++ " and " ++ getTarClone iuh +} + -- Compares the two gz archives. Needed to find that the archive was not incremental showArchiveCompare :: FilePath -> FilePath -> IO() -showArchiveCompare archive1 archive2= do +showArchiveCompare archive1 archive2 = do val <- compareFiles archive1 archive2 putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ show val +archiveCompareCommand :: REPLCommand HackageUpdateInfo +archiveCompareCommand = RC { + cTag = "system", + cMatch = isTrimCommand "system-compare", + cExec = \iuh _ -> showArchiveCompare (getArchive iuh) (getArchiveClone iuh), + cDescription = \iuh -> "system-compare - compares the " ++ + getArchive iuh ++ " with " ++ getArchiveClone iuh +} + updateArchive :: URL -> URL -> FilePath -> IO UpdateResult updateArchive = performArchiveFileUpdate -updateArchiveVoid :: URL -> URL -> FilePath -> IO () -updateArchiveVoid snapshotURL archiveURL archive = - void (performArchiveFileUpdate snapshotURL archiveURL archive) - -updateTotalArchive :: IO UpdateResult -> IO() -> IO() -> IO () -updateTotalArchive update unzip persist = do - putStrLn "Performing total update" - result <- update - if result == ArchiveIsOk then putStrLn "Nothing to update" - else unzip >> persist +updateArchiveCommand :: REPLCommand HackageUpdateInfo +updateArchiveCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "update", + cExec = \iuh _ -> void $ updateArchive (iuhSnapshotURL iuh) (iuhArchiveURL iuh) (getArchive iuh), + cDescription = \iuh -> "update - updates the current " ++ getArchive iuh ++ + " from " ++ iuhArchiveURL iuh +} updatePersistentFromTar :: FilePath -> FilePath -> IO() updatePersistentFromTar updateDir tarFile = do @@ -133,6 +308,15 @@ updatePersistentFromTar updateDir tarFile = do let newMap = buildHackageMap newTar (buildPreHackageMap newTar) updatePersistentMap updateDir newMap + +updatePersistentFromArchiveCommand :: REPLCommand HackageUpdateInfo +updatePersistentFromArchiveCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "tarpersist", + cExec = \iuh _ -> void $ updatePersistentFromTar (getArchivePersistDir iuh) (getTar iuh), + cDescription = \iuh -> "tarpersist - updates the persistent storage with " ++ getTar iuh +} + showPersistentQuery :: FilePath -> PackageName -> IO() showPersistentQuery updateDir name = do putStrLn $ "Querying storage hackage map with " ++ name @@ -143,9 +327,34 @@ showPersistentQuery updateDir name = do print package Nothing -> putStrLn "Not found" +showPersistentQueryCommand :: REPLCommand HackageUpdateInfo +showPersistentQueryCommand = RC { + cTag = "hackage", + cMatch = isPrefixCommand "querypersist ", + cExec = \iuh command -> showPersistentQuery (getArchivePersistDir iuh) (parseValEnd command), + cDescription = const "querypersist name - queries the persistent storage with package" +} + showPersistentTarCompare :: FilePath -> FilePath -> IO() showPersistentTarCompare updateDir tarFile = do newTar <- loadTar tarFile let newMap = buildHackageMap newTar (buildPreHackageMap newTar) printPersistentDiffMap updateDir newMap +showPersistentTarCompareCommand :: REPLCommand HackageUpdateInfo +showPersistentTarCompareCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "cmppersist", + cExec = \iuh _ -> void $ showPersistentTarCompare (getArchivePersistDir iuh) (getTar iuh), + cDescription = \iuh -> "cmppersist - compares the state of " ++ + getTar iuh ++ " with map from persistent storage" +} + +updateAllHackageCommand :: REPLCommand HackageUpdateInfo +updateAllHackageCommand = RC { + cTag = "hackage", + cMatch = isTrimCommand "totalupdate", + cExec = \iuh _ -> cExec updateArchiveCommand iuh "" >> cExec unzipArchiveCommand iuh "" >> + cExec updatePersistentFromArchiveCommand iuh "", + cDescription = const "totalupdate - updates hackage archive, unzips and updates the persistent storage" +} \ No newline at end of file diff --git a/REPL/src/IndexProject.hs b/REPL/src/IndexProject.hs deleted file mode 100644 index 882b151..0000000 --- a/REPL/src/IndexProject.hs +++ /dev/null @@ -1,12 +0,0 @@ -module IndexProject( - processREPLCycle - ) where - -import REPL (processREPLCycle) ---import HackageArchive (HackageName (..), HackagePackage(..)) - - ---HackageUpdateInfo(..), --- HackageName(..), ---updateHackageMap :: HackageUpdateInfo -> IO () ---updateHackageMap iuh = updateArchive iuh >> updateMapFromTar iuh \ No newline at end of file diff --git a/REPL/src/PackageManager.hs b/REPL/src/PackageManager.hs new file mode 100644 index 0000000..438884e --- /dev/null +++ b/REPL/src/PackageManager.hs @@ -0,0 +1,17 @@ +-- This is the only module, needed to use the functionality of persistent storage and updating of the packages +-- It reexports queryCombinedData, function, that looks up package in both +-- hackage and stackage persistent storages and launchPackageUpdater - that +-- can be launched with the config and delay and will update the hackage and stackage archive +-- after every specified time period (time period is specified in minutes) + +module PackageManager( UpdateInfo(..), + CombinedPackage (..), + queryCombinedData, + launchPackageUpdater) where + +import REPL +import AllCommands + + +launchPackageUpdater :: UpdateInfo -> Int -> IO () +launchPackageUpdater ui = processDelayCycle ui updateAllCommand \ No newline at end of file diff --git a/REPL/src/REPL.hs b/REPL/src/REPL.hs index 224b1e2..c19f007 100644 --- a/REPL/src/REPL.hs +++ b/REPL/src/REPL.hs @@ -1,178 +1,136 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module REPL ( processREPLCycle ) where +module REPL ( processREPLCycle, + processDelayCycle, + makeAlwaysCommand, + REPLCommand(..), + isTrimCommand, + isPrefixCommand) where import qualified Data.Char as DC import qualified Control.Exception as X -import Data.List(isPrefixOf) +import Data.List(isPrefixOf, find, nub, dropWhileEnd) +import Data.Maybe(fromMaybe) import Control.Monad(forever, void) import System.IO (stdout, hFlush) import System.Exit(exitSuccess) import Network.HTTP.Client(HttpException) +import Control.Concurrent (threadDelay) + import Common -import qualified HackageCommands as HC -import qualified StackageCommands as SC -import qualified AllCommands as AC -processREPLCycle :: UpdateInfo -> IO () -processREPLCycle ui = forever $ do +data REPLCommand cnf = RC { + -- the tag of the command to display + cTag :: String, + -- returns true if the command matches + cMatch :: String -> Bool, + -- executes the command + cExec :: cnf -> String -> IO (), + -- description of the command + cDescription :: cnf -> String +} + +makeAlwaysCommand :: REPLCommand a -> REPLCommand a +makeAlwaysCommand rc = RC { + cTag = cTag rc, + cMatch = const True, + cExec = cExec rc, + cDescription = cDescription rc +} + +trim = dropWhileEnd DC.isSpace . dropWhile DC.isSpace +isTrimCommand commandValue commandStr = trim commandStr == commandValue + +isPrefixCommand :: String -> String -> Bool +isPrefixCommand = isPrefixOf + +--processREPLCycle = undefined +getDescriptionText :: cnf -> REPLCommand cnf -> String +getDescriptionText config command = cDescription command config + +-- Performs the REPL cycle, until exit of quit command is entered +processREPLCycle :: cnf -> [REPLCommand cnf] -> IO() +processREPLCycle config commands = forever $ do + -- get the next string putStr "Input command: " hFlush stdout - command <- getLine + commandStr <- getLine hFlush stdout - processCommand command `X.catch` eh `X.catch` eh2 `X.catch` eh3 `X.catch` eh4 + -- if the command is not found, than help is shown + let command = findCommand commandStr + -- TODO. well, need to refactor exception handling + cExec command config commandStr `X.catch` eh `X.catch` eh2 `X.catch` eh3 `X.catch` eh4 where - processCommand = buildCommand ui + commandsWithExtra = exitCommand : quitCommand : helpCommand : commands + helpCommand = makeHelpCommand config commandsWithExtra + findCommand str = fromMaybe helpCommand $ find (`cMatch` str) commandsWithExtra + + -- terrible code, definetely needs refactoring. Dunno how to do it better eh (e :: X.IOException) = putStrLn $ "IO Error: " ++ show e eh2 (e :: UpdateArchiveException) = putStrLn $ "Parsing error: " ++ show e eh3 (e :: X.ErrorCall) = putStrLn $ "Error call: " ++ show e eh4 (e :: HttpException) = putStrLn $ "Http exception: " ++ show e -buildCommand :: UpdateInfo -> (String -> IO()) -buildCommand ui = processCommand +processDelayCycle :: cnf -> REPLCommand cnf -> Int -> IO() +processDelayCycle config command minutes = forever $ do + putStrLn "Executing command" + hFlush stdout + cExec (makeAlwaysCommand command) config "" `X.catch` eh `X.catch` eh2 `X.catch` eh3 `X.catch` eh4 + + putStrLn $ "Waiting " ++ show minutes ++ " minutes" + hFlush stdout + threadDelay (minutes * 60000) + where - processCommand command - -- updates all - | chk "allupdate" = AC.totalUpdate ui - -- checks the current hackage gzip archive and understands what to download - | chk "check" = HC.showUpdateData arch snapURL - -- updates the gzip archive file, unpacks it to tar and loads in the permanent storage - | chk "totalupdate" = HC.updateTotalArchive updateCommand unzipCommand persistCommand - -- updates the gzip archive file from hackage - | chk "update" = HC.updateArchiveVoid snapURL archURL arch - -- shows the snapshot of hackage gzip archive file (md5 and length) - | chk "file" = HC.showFileSnapshot arch - -- cuts the end of the hackage gzip archive file for checking purposes - | chk "cut" = HC.cutFile arch (parseIntEnd command) - -- unzips the downloaded gzip archive to tar file - | chk "unzip" = HC.unzipArchive arch trFile - -- removes the gzip and tar files - | chk "clean" = HC.removeArchiveFiles arch trFile - -- shows the first 50 pre elements from tar archive - | chk "tarshowpre" = HC.showTarPreElements trFile 50 - -- shows the first 50 elements from tar archive - | chk "tarshow" = HC.showTarElements trFile 50 - -- Updates the persistent map from tar archive - | chk "tarpersist" = persistCommand - -- compares the map from tar archive and the persistent map - | chk "cmppersist" = HC.showPersistentTarCompare ud trFile - -- shows the package from the persistent map - | chk "querypersist" = HC.showPersistentQuery ud (parseValEnd command) + eh (e :: X.IOException) = putStrLn $ "IO Error: " ++ show e + eh2 (e :: UpdateArchiveException) = putStrLn $ "Parsing error: " ++ show e + eh3 (e :: X.ErrorCall) = putStrLn $ "Error call: " ++ show e + eh4 (e :: HttpException) = putStrLn $ "Http exception: " ++ show e - -- shows the snapshots from stackage - | 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) +-- builds the help command +makeHelpCommand :: cnf -> [REPLCommand cnf] -> REPLCommand cnf +makeHelpCommand config commands = RC { + cTag = "help", + cMatch = (== "help"), + cExec = \_ _ -> putStr commandText, + cDescription = const "help - displays help" + } + where + -- makes the line for the command by adding tab in front and br in back + makeCommandText command = "\t" ++ getDescriptionText config command ++ "\n" - -- exits the REPL - | chk "exit" = exitREPL - | chk "quit" = exitREPL + -- gets all the tags from the list of commands. Nub is slow, but there are not many commands + buildTags = nub . map cTag + -- all of the tags + tags = buildTags commands - -- shows the help for REPL commands - | chk "help" = showHelp ui + -- true, if the command is satisfied with this tag + isTag tag command = cTag command == tag - -- these are the clones of the commands above for the orig files - -- You'll probably won't need them, unless you are me (borboss366) - -- copies the current hackage archive to other file. Needed for checking properties - | chk "system-copyorig" = HC.copyArchive arch archC - | chk "system-checkclone" = HC.showUpdateData archC snapURL - | chk "system-fileclone" = HC.showFileSnapshot archC - | chk "system-cutclone" = HC.cutFile archC (parseIntEnd command) - | chk "system-unzipclone" = HC.unzipArchive archC trFileC - | chk "system-cleanclone" = HC.removeArchiveFiles archC trFileC - | chk "system-tarshowpreclone" = HC.showTarPreElements trFileC 50 - | chk "system-tarshowclone" = HC.showTarElements trFileC 50 - -- compares the gzip archive with orig archive, that was copied some time before - | chk "system-compare" = HC.showArchiveCompare arch archC - -- shows diff map between tar and tar.orig archives - | chk "system-tarcmp" = HC.showDiffMap trFile trFileC + -- gets all the commands according to tags + commandBlocks = map (\tag -> (tag, filter (isTag tag) commands)) tags - -- | chk "urlsize" = HD.calculateContentSize (parseValEnd command) >>= print - | otherwise = showHelp ui + -- makes the text for the block of commands + makeBlockText (tag, commands) = tag ++ ": \n" ++ concatMap makeCommandText commands - where pc = map DC.toLower command - chk val = val `isPrefixOf` pc + commandText = "Available commands: \n" ++ concatMap makeBlockText commandBlocks - arch = (getArchive.iuh) ui - archC = (getArchiveClone.iuh) ui - archURL = (iuhArchiveURL.iuh) ui - snapURL = (iuhSnapshotURL.iuh) ui - trFile = (getTar.iuh) ui - trFileC = (getTarClone.iuh) ui - ud = (getArchivePersistDir.iuh) ui - - snapshotsURL = (getSnapshotURL.sui) ui - - updateCommand = HC.updateArchive snapURL archURL arch - unzipCommand = HC.unzipArchive arch trFile - persistCommand = HC.updatePersistentFromTar ud trFile - - ltsFileDir = getLTSFilesDir (sui ui) - ltsURL = suiLTSURL (sui ui) - sud = (getLTSPersistDir.sui) ui - - - -showHelp :: UpdateInfo -> IO() -showHelp ui = do - putStrLn "Available commands: " - - putStrLn $ "check - downloads the json length and md5 hash from " ++ snapURL ++ - ", and compares it with local " ++ arch - putStrLn $ "file - displays the current " ++ arch ++ " length and md5 hash" - putStrLn $ "cut size - cuts the size bytes from the end of the " ++ arch ++ " , for update command" - putStrLn $ "unzip - unzips the " ++ arch ++ " in the " ++ trFile ++ " file" - putStrLn $ "clean - deletes the " ++ arch ++ " and " ++ trFile - putStrLn $ "update - updates the current " ++ arch ++ " from " ++ archURL - putStrLn $ "totalupdate - updates the current " ++ arch ++ " from " ++ archURL - putStrLn $ "tarshow - loads the map of entries from " ++ trFile ++ " and displays it" - putStrLn $ "tarshowpre - loads the premap of entries from " ++ trFile ++ " and displays it" - putStrLn $ "cmppersist - compares the state of " ++ trFile ++ " with map from persistent storage" - putStrLn $ "tarpersist - updates the persistent storage with " ++ trFile - putStrLn "querypersist name - queries the persistent storage with package" - putStrLn $ "snapshots - show the stackage snapshots from " ++ snapshotsURL - putStrLn "exit - exits this repl" - putStrLn "help - shows this help" - -{- - putStrLn $ "compare - compares the " ++ arch ++ " with " ++ archC - putStrLn $ "tarcmp - compares the entries of " ++ trFile ++ " and " ++ trFileC - - putStrLn $ "acidcmp - compares the state of " ++ trFile ++ " with map from acid state" - putStrLn $ "acidupdate - updates the acid state with " ++ trFile - putStrLn "acidquery name - queries the acid with package" - putStrLn $ "checkclone - same for " ++ archC - putStrLn $ "fileclone - same for " ++ archC ++ " file" - putStrLn $ "copyorig - copy the " ++ arch ++ " to " ++ archC - putStrLn "cutclone size - cuts the size bytes from the end of the 01-index.tar.gz, for update command" - putStrLn $ "unzipclone - unzips the " ++ archC ++ " in the " ++ trFileC ++ " file" - putStrLn $ "cleanclone - deletes the " ++ archC ++ " and " ++ trFileC --} - where - arch = (getArchive.iuh) ui - archC = (getArchiveClone.iuh) ui - archURL = (iuhArchiveURL.iuh) ui - snapURL = (iuhSnapshotURL.iuh) ui - trFile = (getTar.iuh) ui - trFileC = (getTarClone.iuh) ui - snapshotsURL = (getSnapshotURL.sui) ui +exitCommand = RC { + cTag = "exit", + cMatch = isTrimCommand "exit", + cExec = \_ _ -> exitREPL, + cDescription = const "exit - exits the REPL" +} +quitCommand = RC { + cTag = "exit", + cMatch = isTrimCommand "quit", + cExec = \_ _ -> exitREPL, + cDescription = const "quit - exits the REPL" +} exitREPL :: IO() -exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess \ No newline at end of file +exitREPL = putStrLn "Finished working with REPL" >> exitSuccess diff --git a/REPL/src/StackageArchive.hs b/REPL/src/StackageArchive.hs index 1d82a31..ba83f7a 100644 --- a/REPL/src/StackageArchive.hs +++ b/REPL/src/StackageArchive.hs @@ -81,7 +81,6 @@ $(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 diff --git a/REPL/src/StackageCommands.hs b/REPL/src/StackageCommands.hs index 0458af6..350d91a 100644 --- a/REPL/src/StackageCommands.hs +++ b/REPL/src/StackageCommands.hs @@ -1,18 +1,68 @@ module StackageCommands( - showSnapshots, - showLTSContents, - showStackageMapContents, - showPersistentQuery, - updateLTSFile, - updateAllLTSFiles, - updatePersistentMapFromLTS) where + stackageCommands, + updatePersistentMapFromLTSCommand, + StackageUpdateInfo(..), + getSnapshotURL, + getLTSGithubURL, + getLTSFilesDir, + getLTSStackageURL, + getLTSFile, + getLTSPersistDir, + defaultSUI) where import qualified Data.ByteString as BS import qualified Data.Map.Strict as M +import System.FilePath(()) +import Data.Default import Common import StackageUpdate import StackageArchive +import REPL + +getLTSStackageURL :: StackageUpdateInfo -> LongSnapshotName -> URL +getLTSStackageURL sui name = suiStackageURL sui name "cabal.config" + +getSnapshotURL :: StackageUpdateInfo -> URL +getSnapshotURL sui = suiStackageURL sui "download/lts-snapshots.json" + +getLTSGithubURL :: StackageUpdateInfo -> LongSnapshotName -> URL +getLTSGithubURL sui name = suiLTSURL sui (name ++ ".yaml") + +getLTSFilesDir :: StackageUpdateInfo -> FilePath +getLTSFilesDir sui = suiUpdateDir sui "ltsfiles" + +getLTSFile :: StackageUpdateInfo -> String -> FilePath +getLTSFile sui lts = getLTSFilesDir sui (lts ++ ".yaml") + +data StackageUpdateInfo = SUI { + suiUpdateDir :: FilePath, + suiStackageURL :: URL, + suiLTSURL :: URL +} deriving (Eq, Show) + +instance Default StackageUpdateInfo where + def = defaultSUI + +getLTSPersistDir :: StackageUpdateInfo -> FilePath +getLTSPersistDir sui = suiUpdateDir sui "persist" + +defaultSUI :: StackageUpdateInfo +defaultSUI = SUI { + suiUpdateDir = "stackagefiles", + suiStackageURL = "https://www.stackage.org/", + suiLTSURL = "https://raw.githubusercontent.com/fpco/lts-haskell/master/" +} + +stackageCommands :: [REPLCommand StackageUpdateInfo] +stackageCommands = [ + showSnapshotsCommand, + showLTSContentsCommand, + updateLTSFileCommand, + updateAllLTSFilesCommand, + showStackageMapContentsCommand, + updatePersistentMapFromLTSCommand, + showPersistentQueryCommand] showSnapshots :: URL -> IO () showSnapshots url = do @@ -20,6 +70,14 @@ showSnapshots url = do putStrLn $ "Showing snapshots from " ++ url mapM_ (putStrLn.(\s -> "\tSnapshot: " ++ s).show) snapshots +showSnapshotsCommand :: REPLCommand StackageUpdateInfo +showSnapshotsCommand = RC { + cTag = "stackage", + cMatch = isTrimCommand "ltssnapshots", + cExec = \sui _ -> showSnapshots (getSnapshotURL sui), + cDescription = \sui -> "ltssnapshots - show the stackage snapshots from " ++ getSnapshotURL sui +} + showLTSContents :: FilePath -> IO () showLTSContents ltsFile = do putStrLn $ "Showing the contents of " ++ ltsFile @@ -27,16 +85,42 @@ showLTSContents ltsFile = do datum <- parseYamlFileThrow body print datum +showLTSContentsCommand :: REPLCommand StackageUpdateInfo +showLTSContentsCommand = RC { + cTag = "stackage", + cMatch = isPrefixCommand "ltsshowcont ", + cExec = \sui commandStr -> let lts = parseValEnd commandStr in showLTSContents (getLTSFile sui lts), + cDescription = const "ltsshowcont lts - shows the contents of specified downloaded lts file" +} + -- updates the lts file from github updateLTSFile :: FilePath -> URL -> IO () updateLTSFile = fetchLTS +updateLTSFileCommand :: REPLCommand StackageUpdateInfo +updateLTSFileCommand = RC { + cTag = "stackage", + cMatch = isPrefixCommand "ltsupdate ", + cExec = \sui commandStr -> let lts = parseValEnd commandStr in + updateLTSFile (getLTSFile sui lts) (getLTSGithubURL sui lts) , + cDescription = const "ltsupdate lts - updates the specified lts file from github" +} + -- 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) +updateAllLTSFilesCommand :: REPLCommand StackageUpdateInfo +updateAllLTSFilesCommand = RC { + cTag = "stackage", + cMatch = isTrimCommand "ltsallupdate", + cExec = \sui commandStr -> updateAllLTSFiles (getLTSFilesDir sui) (suiLTSURL sui) (getSnapshotURL sui), + cDescription = const "ltsallupdate - updates all lts files from github using snapshot from stackage" +} + + showStackageMapContents :: FilePath -> URL -> URL -> Int -> IO() showStackageMapContents ltsDir ltsURL snapshotsURL count = do putStrLn "Fetching snapshot lists" @@ -48,6 +132,16 @@ showStackageMapContents ltsDir ltsURL snapshotsURL count = do putStrLn $ "Printing " ++ show count ++ " packages" mapM_ print $ take count $ M.toList map +showStackageMapContentsCommand :: REPLCommand StackageUpdateInfo +showStackageMapContentsCommand = RC { + cTag = "stackage", + cMatch = isTrimCommand "ltsshowmap", + cExec = \sui commandStr -> + showStackageMapContents (getLTSFilesDir sui) (suiLTSURL sui) (getSnapshotURL sui) 20, + cDescription = const $ "ltsshowmap - downloads lts files and shots the part of" ++ + " stackage package map from them" +} + updatePersistentMapFromLTS :: FilePath -> FilePath -> URL -> URL -> IO() updatePersistentMapFromLTS updateDir ltsDir ltsURL snapshotsURL = do putStrLn "Fetching snapshot lists" @@ -58,6 +152,17 @@ updatePersistentMapFromLTS updateDir ltsDir ltsURL snapshotsURL = do map <- generateStackageMap ltsDir (filterNormal snapshots) updatePersistentMap updateDir map +updatePersistentMapFromLTSCommand :: REPLCommand StackageUpdateInfo +updatePersistentMapFromLTSCommand = RC { + cTag = "stackage", + cMatch = isTrimCommand "ltsupdatepersist", + cExec = \sui commandStr -> + updatePersistentMapFromLTS + (suiUpdateDir sui) (getLTSFilesDir sui) (suiLTSURL sui) (getSnapshotURL sui), + cDescription = const $ "ltsupdatepersist - gets all the lts snapshots from the stackage, " ++ + "updates the lts files according to them and then updates the persistent storage" +} + showPersistentQuery :: FilePath -> PackageName -> IO() showPersistentQuery updateDir name = do putStrLn $ "Querying storage stackage map with " ++ name @@ -67,3 +172,12 @@ showPersistentQuery updateDir name = do putStrLn "Found" print package Nothing -> putStrLn "Not found" + +showPersistentQueryCommand :: REPLCommand StackageUpdateInfo +showPersistentQueryCommand = RC { + cTag = "stackage", + cMatch = isPrefixCommand "ltsquerypersist", + cExec = \sui commandStr -> let lts = parseValEnd commandStr in + showPersistentQuery (suiUpdateDir sui) lts, + cDescription = const "ltsquerypersist package - queries the persistent map of the stackage packages" +} diff --git a/REPL/test/Spec.hs b/REPL/test/Spec.hs index 7c3eb0f..5a5aea9 100644 --- a/REPL/test/Spec.hs +++ b/REPL/test/Spec.hs @@ -10,7 +10,7 @@ import qualified Data.Text as T import Data.Monoid ((<>)) import System.FilePath(()) import HackageArchive -import Stackage +import Common import qualified Data.Text.IO as TIO @@ -29,6 +29,7 @@ testPath :: T.Text -> T.Text -> Bool -> TestTree testPath text val match = testCase (T.unpack ("Parsing " <> expect match <> " \'" <> text <> "\'")) $ assertBool "Failed" $ ((fst <$> parsePath (T.unpack text)) == Just (T.unpack val)) == match +{- parseStackageTests = testGroup "Stackage parsing tests" [ testParse parsePackageLine " ztail ==1.2" True @@ -53,6 +54,7 @@ parseCabalConfig = testGroup "Cabal config parsing tests" , testStackagePackageLines parseStackageLTS "sometestfile2.cnf" , testFileJustParse parseStackageLTS "sometestfile3.cnf" True ] +-} -- Well this is code duplication. Somehow need to use testParse function here @@ -91,6 +93,6 @@ testFileParse file p textFunc matchFunc = assertBool "Failed" (either (const False) id eVal) tests :: TestTree -tests = testGroup "REPL tests" [parseStackageTests, parseTests, parseCabalConfig] +tests = testGroup "REPL tests" [parseTests] main = defaultMain tests