mirror of
https://github.com/aelve/guide.git
synced 2024-11-25 18:56:52 +03:00
Made almost nice REPL and module for hackage and stackage lookup and update
This commit is contained in:
Boris M. Yartsev
parent
ee373b4b87
commit
29f879962e
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
-}
|
||||
|
||||
-- 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
|
||||
@ -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/"
|
||||
}
|
||||
type StackageLTS = (LongSnapshotName, [PackageData])
|
||||
@ -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"
|
||||
}
|
||||
@ -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
|
||||
17
REPL/src/PackageManager.hs
Normal file
17
REPL/src/PackageManager.hs
Normal file
@ -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
|
||||
246
REPL/src/REPL.hs
246
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
|
||||
exitREPL = putStrLn "Finished working with REPL" >> exitSuccess
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user