diff --git a/REPL/app/Main.hs b/REPL/app/Main.hs index f4f0529..a2ee8b5 100644 --- a/REPL/app/Main.hs +++ b/REPL/app/Main.hs @@ -3,18 +3,8 @@ module Main where -import qualified Data.ByteString.Lazy as BL -import Data.Int(Int64) -import qualified Control.Exception as X -import qualified Data.Char as DC -import qualified Data.List as DL -import Control.Monad(forever) -import System.Directory(copyFile) -import System.IO (stdout, hFlush) -import qualified Data.Map.Strict as Map import Data.Default - import IndexProject main :: IO () -main = processCycle def +main = processREPLCycle def diff --git a/REPL/index-project.cabal b/REPL/index-project.cabal index fe04aa5..c84c57c 100644 --- a/REPL/index-project.cabal +++ b/REPL/index-project.cabal @@ -15,7 +15,9 @@ cabal-version: >=1.10 library hs-source-dirs: src - other-modules: Common, FileUtils, HttpDownload, HackageUpdate, REPL, Storage + other-modules: Common, FileUtils, HttpDownload, HackageUpdate, REPL + , HackageCommands, StackageUpdate, StackageCommands + exposed-modules: IndexProject, HackageArchive, Stackage build-depends: base >= 4.7 && < 5 , directory @@ -42,6 +44,7 @@ library , transformers , zlib , acid-state + , unordered-containers default-language: Haskell2010 diff --git a/REPL/src/Common.hs b/REPL/src/Common.hs index 502889d..38ed3de 100644 --- a/REPL/src/Common.hs +++ b/REPL/src/Common.hs @@ -1,15 +1,27 @@ module Common(URL, PackageName, + PackageVersion(..), PackageData, SnapshotData(..), UpdateArchiveException(..), + UpdateInfo(..), HackageUpdateInfo(..), getArchive, getArchiveClone, getTar, getTarClone, parseIntEnd, - parseValEnd) where + parseValEnd, + + ShortSnapshotName, + LongSnapshotName, + shortName, + longName, + getSnapshotURL, + StackageSnapshot, + StackageSnapshots(..), + StackageLTS, + StackageUpdateInfo(..)) where import qualified Control.Exception as X import qualified Data.ByteString.Lazy as BL @@ -23,7 +35,22 @@ import System.FilePath(()) type URL = String type PackageName = String -type PackageData = (PackageName, DV.Version) +data PackageVersion = Installed | Specified DV.Version deriving (Eq, Ord, Show) +type PackageData = (PackageName, PackageVersion) + +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, @@ -42,6 +69,7 @@ data HackageUpdateInfo = IUH { iuhArchiveURL :: URL } deriving (Eq, Show) + instance Default HackageUpdateInfo where def = defaultIUH @@ -86,3 +114,35 @@ parseValEnd :: String -> String parseValEnd val | DL.length l > 1 = DL.last l | otherwise = "" where l = words val + + +-- Stackage stuff +type ShortSnapshotName = String +type LongSnapshotName = String +type StackageSnapshot = (ShortSnapshotName, LongSnapshotName) +newtype StackageSnapshots = SSS [StackageSnapshot] deriving (Eq, Show) + +shortName :: StackageSnapshot -> String +shortName = fst + +longName :: StackageSnapshot -> String +longName = snd + +type StackageLTS = (LongSnapshotName, [PackageData]) + +getLTSURL :: StackageUpdateInfo -> LongSnapshotName -> URL +getLTSURL sui name = suiStackageURL sui name "cabal.config" + +getSnapshotURL :: StackageUpdateInfo -> URL +getSnapshotURL sui = suiStackageURL sui "download/lts-snapshots.json" + +data StackageUpdateInfo = SUI { + suiUpdateDir :: FilePath, + suiStackageURL :: URL +} deriving (Eq, Show) + +defaultSUI :: StackageUpdateInfo +defaultSUI = SUI { + suiUpdateDir = "stackagefiles", + suiStackageURL = "https://www.stackage.org/" +} \ No newline at end of file diff --git a/REPL/src/HackageArchive.hs b/REPL/src/HackageArchive.hs index d30b72a..28843c8 100644 --- a/REPL/src/HackageArchive.hs +++ b/REPL/src/HackageArchive.hs @@ -1,9 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} module HackageArchive ( buildDifferenceMap, buildHackageMap, buildPreHackageMap, + + updatePersistentMap, + printPersistentDiffMap, + queryPersistentMap, + HackagePackage (..), HackageName, HackageMap, @@ -26,11 +34,18 @@ import qualified Distribution.PackageDescription.Parse as DPDP import qualified Data.Map.Strict as M import qualified Control.Exception as X +import Data.Typeable +import Data.Acid +import Data.Acid.Advanced +import Data.SafeCopy +import Control.Monad.Reader + import Data.Maybe import Debug.Trace import Control.Monad(guard) import qualified Data.ByteString.Lazy.UTF8 as UTFC +import qualified Control.Monad.State as State import System.FilePath.Posix(hasTrailingPathSeparator) import Common @@ -40,9 +55,8 @@ type HackageName = String -- The record for each of the package from hackage -- TODO - add another information about the packages data HackagePackage = HP { --- packageData :: HHPathData name :: HackageName, - version :: DV.Version, + pVersion :: DV.Version, author :: String } deriving (Eq, Show) @@ -52,8 +66,7 @@ data HackageUpdate = Added | Removed | Updated deriving (Eq, Show) -- The map of all the hackage packages with name as the key and HackagePackage -- as the value type HackageMap = M.Map HackageName HackagePackage - -type PreHackageMap = M.Map HackageName DV.Version +type PreHackageMap = M.Map HackageName PackageVersion -- The map, that shows, which packages have change since the last update type HackageUpdateMap = M.Map HackageName (HackageUpdate, HackagePackage) @@ -69,7 +82,7 @@ parseCabalFilePath = do guard (name == package) suff <- RP.string ".cabal" RP.eof - pure (package, version) + pure (package, Specified version) where phi l = DC.isLetter l || l == '-' updateMapCompare :: (Ord a) => String -> a -> M.Map String a -> M.Map String a @@ -90,7 +103,7 @@ buildDifferenceMap oldMap newMap = foldr M.union M.empty [deletedMap, addedMap, diff newpack oldpack = if newpack /= oldpack then Just newpack else Nothing createPackage :: DPD.PackageDescription -> HackagePackage -createPackage pd = HP { name = nm, version = ver, author = auth } +createPackage pd = HP { name = nm, pVersion = ver, author = auth } where pkg = DPD.package pd nm = DP.unPackageName (DP.pkgName pkg) @@ -143,3 +156,56 @@ buildHackageMap Tar.Done _ = M.empty buildHackageMap (Tar.Fail e) _ = X.throw e +-- The stuff needed for acid serialization +newtype KeyValue = KeyValue HackageMap deriving (Typeable) + +$(deriveSafeCopy 0 'base ''DV.Version) +$(deriveSafeCopy 0 'base ''HackagePackage) +$(deriveSafeCopy 0 'base ''KeyValue) +$(deriveSafeCopy 0 'base ''HackageUpdate) + +insertKey :: HackageName -> HackagePackage -> Update KeyValue () +insertKey key value = do + KeyValue hackageMap <- State.get + State.put (KeyValue (M.insert key value hackageMap)) + +updateMap :: HackageMap -> Update KeyValue () +updateMap newMap = State.put (KeyValue newMap) + +lookupKey :: HackageName -> Query KeyValue (Maybe HackagePackage) +lookupKey key = do + KeyValue m <- ask + return (M.lookup key m) + +compareMap :: HackageMap -> Query KeyValue HackageUpdateMap +compareMap newMap = do + KeyValue oldMap <- ask + return (buildDifferenceMap oldMap newMap) + +$(makeAcidic ''KeyValue ['insertKey, 'lookupKey, 'compareMap, 'updateMap]) + + +updatePersistentMap :: FilePath -> HackageMap -> IO () +updatePersistentMap path newMap = do + acid <- openLocalStateFrom path (KeyValue M.empty) + do + putStrLn "Updating the persistent map" + update acid (UpdateMap newMap) + closeAcidState acid + +printPersistentDiffMap :: FilePath -> HackageMap -> IO () +printPersistentDiffMap path newMap = do + acid <- openLocalStateFrom path (KeyValue M.empty) + do + diffMap <- query acid (CompareMap newMap) + putStrLn "Printing difference map with persistent map" + mapM_ (print.snd) $ M.toList diffMap + closeAcidState acid + +queryPersistentMap :: FilePath -> HackageName -> IO (Maybe HackagePackage) +queryPersistentMap path name = do + acid <- openLocalStateFrom path (KeyValue M.empty) + val <- query acid (LookupKey name) + closeAcidState acid + return val + \ No newline at end of file diff --git a/REPL/src/HackageCommands.hs b/REPL/src/HackageCommands.hs new file mode 100644 index 0000000..5c64521 --- /dev/null +++ b/REPL/src/HackageCommands.hs @@ -0,0 +1,151 @@ +module HackageCommands( + showTarElements, + showTarPreElements, + showFileSnapshot, + showFileSubstring, + showUpdateData, + copyArchive, + showDiffMap, + cutFile, + unzipArchive, + removeArchiveFiles, + showArchiveCompare, + updateArchive, + updateArchiveVoid, + updateTotalArchive, + + updatePersistentFromTar, + showPersistentQuery, + showPersistentTarCompare + ) where + +import qualified Data.Map.Strict as M +import Data.Int(Int64) +import System.Directory(copyFile) +import Control.Monad(void) + +import FileUtils +import Common +import HackageArchive +import HackageUpdate + +-- shows the first count elements, parsed from the tar archive +showTarElements :: FilePath -> Int -> IO () +showTarElements path count = do + putStrLn $ "Displaying " ++ show count ++ " entries for " ++ path + tar <- loadTar path + mapM_ (print.snd) $ take count $ M.toList $ buildHackageMap tar (buildPreHackageMap tar) + +-- shows the first count pre elements (only path is parsed) form the tar archive +showTarPreElements :: FilePath -> Int -> IO () +showTarPreElements path count = do + putStrLn $ "Pre displaying " ++ show count ++ " entries for " ++ path + tar <- loadTar path + mapM_ print $ take count $ M.toList $ buildPreHackageMap tar + +-- Displays the snapshot of the file +showFileSnapshot :: FilePath -> IO() +showFileSnapshot file = do + filesnapshot <- calcFileData file + putStrLn $ "File result for " ++ file + putStrLn $ "\tFile snapshot: " ++ show filesnapshot + + +-- Shows the update data for the archive on disk +showUpdateData :: FilePath -> URL -> IO() +showUpdateData file json = do + (range, snapshot, filesnapshot) <- calcUpdateResultIO file json + putStrLn $ "Update result for file " ++ file + putStrLn $ "\tHackage snapshot: " ++ show snapshot + putStrLn $ "\tFile snapshot: " ++ show filesnapshot + putStrLn $ "\tRange to update: " ++ show range + +-- shows the substring of specified length from file from offset +showFileSubstring :: FilePath -> Int64 -> Int64 -> IO () +showFileSubstring file from length = do + putStrLn $ "Showing " ++ file ++ " substr" + putStr "\t" + substr <- getFileSubstring file from length + print substr + +-- Copies the archive from first filename to the second +copyArchive :: FilePath -> FilePath -> IO () +copyArchive archive1 archive2 = do + copyFile archive1 archive2 + putStrLn $ "Copied the " ++ archive1 ++ " to " ++ archive2 + +-- Shows the difference between two tar archives, by building the pre maps of +-- each of them, and then comparing +showDiffMap :: FilePath -> FilePath -> IO () +showDiffMap newTarFile oldTarFile = do + putStrLn $ "Displaying difference between " ++ newTarFile ++ " and " ++ oldTarFile + newTar <- loadTar newTarFile + oldTar <- loadTar oldTarFile + let newMap = buildHackageMap newTar (buildPreHackageMap newTar) + let oldMap = buildHackageMap oldTar (buildPreHackageMap oldTar) + let diffMap = buildDifferenceMap oldMap newMap + mapM_ (print.snd) $ M.toList diffMap + + +-- 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() +cutFile path size = do + truncateIfExists path size + putStrLn $ "Cut " ++ show size ++ " bytes from " ++ path + +-- Unzips the gz archive to tar +unzipArchive :: FilePath -> FilePath -> IO() +unzipArchive archive tar = do + putStrLn $ "Unzipping " ++ archive ++ " to " ++ tar + unzipFile archive tar + +-- Removes gz and tar files +removeArchiveFiles :: FilePath -> FilePath -> IO() +removeArchiveFiles archive tar = do + putStrLn $ "Removing archive files " ++ archive ++ " " ++ tar + removeIfExists archive + removeIfExists tar + +-- Compares the two gz archives. Needed to find that the archive was not incremental +showArchiveCompare :: FilePath -> FilePath -> IO() +showArchiveCompare archive1 archive2= do + val <- compareFiles archive1 archive2 + putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ show val + +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 + +updatePersistentFromTar :: FilePath -> FilePath -> IO() +updatePersistentFromTar updateDir tarFile = do + newTar <- loadTar tarFile + let newMap = buildHackageMap newTar (buildPreHackageMap newTar) + updatePersistentMap updateDir newMap + + +showPersistentQuery :: FilePath -> HackageName -> IO() +showPersistentQuery updateDir name = do + putStrLn $ "Querying storage hackage map with " ++ name + value <- queryPersistentMap updateDir name + case value of + Just package -> do + putStrLn "Found" + print package + Nothing -> putStrLn "Not found" + +showPersistentTarCompare :: FilePath -> FilePath -> IO() +showPersistentTarCompare updateDir tarFile = do + newTar <- loadTar tarFile + let newMap = buildHackageMap newTar (buildPreHackageMap newTar) + printPersistentDiffMap updateDir newMap diff --git a/REPL/src/HackageUpdate.hs b/REPL/src/HackageUpdate.hs index 62a9184..c833e73 100644 --- a/REPL/src/HackageUpdate.hs +++ b/REPL/src/HackageUpdate.hs @@ -2,7 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module HackageUpdate ( performArchiveFileUpdate, - calcUpdateResultIO) where + calcUpdateResultIO, + UpdateResult(..)) where import Data.Aeson.Types import qualified Data.Aeson as A @@ -67,7 +68,7 @@ calcUpdateResultIO file json = do parseSnapshotJSONThrow :: BL.ByteString -> IO HackageSnapshotData parseSnapshotJSONThrow body = case A.decode body of (Just snapshot) -> return snapshot - Nothing -> X.throwIO $ UAE "Could not decode JSON" + Nothing -> X.throwIO $ UAE "Could not decode hackage JSON" -- Returns the snapshot of archive from the hackage fetchSnapshot :: URL -> IO HackageSnapshotData diff --git a/REPL/src/IndexProject.hs b/REPL/src/IndexProject.hs index 4fc25f9..882b151 100644 --- a/REPL/src/IndexProject.hs +++ b/REPL/src/IndexProject.hs @@ -1,12 +1,12 @@ -module IndexProject(HackageUpdateInfo(..), - HackageName(..), - processCycle, - updateHackageMap, - queryHackageMap +module IndexProject( + processREPLCycle ) where -import REPL (HackageUpdateInfo(..), processCycle, updateArchive, updateMapFromTar, queryHackageMap) -import HackageArchive (HackageName (..), HackagePackage(..)) +import REPL (processREPLCycle) +--import HackageArchive (HackageName (..), HackagePackage(..)) -updateHackageMap :: HackageUpdateInfo -> IO () -updateHackageMap iuh = updateArchive iuh >> updateMapFromTar iuh + +--HackageUpdateInfo(..), +-- HackageName(..), +--updateHackageMap :: HackageUpdateInfo -> IO () +--updateHackageMap iuh = updateArchive iuh >> updateMapFromTar iuh \ No newline at end of file diff --git a/REPL/src/REPL.hs b/REPL/src/REPL.hs index d378398..4161ea1 100644 --- a/REPL/src/REPL.hs +++ b/REPL/src/REPL.hs @@ -1,253 +1,153 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module REPL ( processCycle, - updateArchive, - updateMapFromTar, - queryHackageMap, - HackageUpdateInfo (..) - ) where +module REPL ( processREPLCycle ) where -import qualified Data.Map.Strict as M import qualified Data.Char as DC import qualified Control.Exception as X + +import Data.List(isPrefixOf) import Control.Monad(forever, void) import System.IO (stdout, hFlush) - -import Data.Int(Int64) import System.Exit(exitSuccess) -import System.Directory(copyFile) -import System.FilePath(()) -import Data.List(isPrefixOf) import Common -import HackageArchive -import HackageUpdate -import FileUtils -import HttpDownload -import Storage +import qualified HackageCommands as HC +import qualified StackageCommands as SC -processCycle :: HackageUpdateInfo -> IO () -processCycle iuh = forever $ do +processREPLCycle :: UpdateInfo -> IO () +processREPLCycle ui = forever $ do putStr "Input command: " hFlush stdout command <- getLine hFlush stdout processCommand command `X.catch` eh `X.catch` eh2 `X.catch` eh3 where - processCommand = buildCommand iuh + processCommand = buildCommand ui 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 -buildCommand :: HackageUpdateInfo -> (String -> IO()) -buildCommand iuh = processCommand +buildCommand :: UpdateInfo -> (String -> IO()) +buildCommand ui = processCommand where processCommand command - -- checks the current gzip archive and understands what to download - | chk "checkclone" = showUpdateData archC snapURL - -- checks the current gzip archive and understands what to download - | chk "check" = showUpdateData arch snapURL + -- 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) - | chk "fileclone" = showFileSnapshot archC - | chk "file" = showFileSnapshot arch -- shows the snapshot of hackage file - - | chk "copyorig" = copyArchive arch archC -- copies the current archive to the orig place - - | chk "cutclone" = cutFile archC (parseIntEnd command) - | chk "cut" = cutFile arch (parseIntEnd command) -- cuts the end of the gzip file for checking purposes - - | chk "unzipclone" = unzipArchive archC trFileC -- unzips the downloaded gzip archive - | chk "unzip" = unzipArchive arch trFile -- unzips the downloaded gzip archive - - | chk "cleanclone" = removeArchiveFiles archC trFileC - | chk "clean" = removeArchiveFiles arch trFile - - | chk "tarparsepreclone" = showPreMap trFileC 50 -- loads the tar clone information in the memory - | chk "tarparsepre" = showPreMap trFile 50 -- loads the tar information in the memory - - | chk "tarparseclone" = showMap trFileC 50 -- loads the tar clone information in the memory - | chk "tarparse" = showMap trFile 50 -- loads the tar information in the memory - - | chk "compare" = showArchiveCompare arch archC - | chk "update" = void $ performArchiveFileUpdate snapURL archURL arch - - | chk "acidcompare" = printAcidCompare ud trFile - | chk "acidupdate" = acidUpdate ud trFile - | chk "acidquery" = showAcidQuery ud (parseValEnd command) - - | chk "tarcmp" = showDiffMap trFile trFileC + -- shows the snapshots from stackage + | chk "snapshots" = SC.showSnapshots snapshotsURL + -- exits the REPL | chk "exit" = exitREPL + | chk "quit" = exitREPL - | chk "help" = showHelp iuh - | otherwise = showHelp iuh + -- shows the help for REPL commands + | chk "help" = showHelp ui + + -- 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 + + | otherwise = showHelp ui where pc = map DC.toLower command chk val = val `isPrefixOf` pc - arch = getArchive iuh - archC = getArchiveClone iuh - archURL = iuhArchiveURL iuh - snapURL = iuhSnapshotURL iuh - trFile = getTar iuh - trFileC = getTarClone iuh - ud = iuhUpdateDir iuh + 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 = (iuhUpdateDir.iuh) ui -showHelp :: HackageUpdateInfo -> IO() -showHelp iuh = do + snapshotsURL = (getSnapshotURL.sui) ui + + updateCommand = HC.updateArchive snapURL archURL arch + unzipCommand = HC.unzipArchive arch trFile + persistCommand = HC.updatePersistentFromTar ud trFile + + +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 $ "checkclone - same for " ++ archC putStrLn $ "file - displays the current " ++ arch ++ " length and md5 hash" - putStrLn $ "fileclone - same for " ++ archC ++ " file" - putStrLn $ "copyorig - copy the " ++ arch ++ " to " ++ archC putStrLn $ "cut size - cuts the size bytes from the end of the " ++ arch ++ " , for update command" - putStrLn "cutclone size - cuts the size bytes from the end of the 01-index.tar.gz, for update command" putStrLn $ "unzip - unzips the " ++ arch ++ " in the " ++ trFile ++ " file" - putStrLn $ "unzipclone - unzips the " ++ archC ++ " in the " ++ trFileC ++ " file" putStrLn $ "clean - deletes the " ++ arch ++ " and " ++ trFile - putStrLn $ "cleanclone - deletes the " ++ archC ++ " and " ++ trFileC - putStrLn $ "compare - compares the " ++ arch ++ " with " ++ archC - putStrLn $ "tarparse - loads the map of entries from " ++ trFile ++ " and displays it" - putStrLn $ "tarparseclone - same for " ++ trFileC - putStrLn $ "tarparsepre - loads the premap of entries from " ++ trFile ++ " and displays it" - putStrLn $ "tarparsepreclone - same for " ++ trFileC - putStrLn $ "tarcmp - compares the entries of " ++ trFile ++ " and " ++ trFileC putStrLn $ "update - updates the current " ++ arch ++ " from " ++ archURL - putStrLn $ "acidcompare - compares the state of " ++ trFile ++ " with map from acid state" + 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 "exit - exits this repl" - + 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 - archC = getArchiveClone iuh - archURL = iuhArchiveURL iuh - snapURL = iuhSnapshotURL iuh - trFile = getTar iuh - trFileC = getTarClone iuh - - --- Displays the snapshot of the file -showFileSnapshot :: FilePath -> IO() -showFileSnapshot file = do - filesnapshot <- calcFileData file - putStrLn $ "File result for " ++ file - putStrLn $ "\tFile snapshot: " ++ show filesnapshot - --- Shows the update data for the archive on disk -showUpdateData :: FilePath -> URL -> IO() -showUpdateData file json = do - (range, snapshot, filesnapshot) <- calcUpdateResultIO file json - putStrLn $ "Update result for file " ++ file - putStrLn $ "\tHackage snapshot: " ++ show snapshot - putStrLn $ "\tFile snapshot: " ++ show filesnapshot - putStrLn $ "\tRange to update: " ++ show range - --- shows the substring of specified length from file from offset -showFileSubstring :: FilePath -> Int64 -> Int64 -> IO () -showFileSubstring file from length = do - putStrLn $ "Showing " ++ file ++ " substr" - putStr "\t" - substr <- getFileSubstring file from length - print substr - --- Copies the archive from first filename to the second -copyArchive :: FilePath -> FilePath -> IO () -copyArchive archive1 archive2 = do - copyFile archive1 archive2 - putStrLn $ "Copied the " ++ archive1 ++ " to " ++ archive2 - -showMap :: FilePath -> Int -> IO () -showMap path count = do - putStrLn $ "Displaying " ++ show count ++ " entries for " ++ path - tar <- loadTar path - mapM_ (print.snd) $ take count $ M.toList $ buildHackageMap tar (buildPreHackageMap tar) - -showPreMap :: FilePath -> Int -> IO () -showPreMap path count = do - putStrLn $ "Pre displaying " ++ show count ++ " entries for " ++ path - tar <- loadTar path - mapM_ print $ take count $ {-filter ((elem '-').fst) $-} M.toList $ buildPreHackageMap tar - - -showDiffMap :: FilePath -> FilePath -> IO () -showDiffMap newTarFile oldTarFile = do - putStrLn $ "Displaying difference between " ++ newTarFile ++ " and " ++ oldTarFile - newTar <- loadTar newTarFile - oldTar <- loadTar oldTarFile - let newMap = buildHackageMap newTar (buildPreHackageMap newTar) - let oldMap = buildHackageMap oldTar (buildPreHackageMap oldTar) - let diffMap = buildDifferenceMap oldMap newMap - mapM_ (print.snd) $ M.toList diffMap - -showArchiveCompare :: FilePath -> FilePath -> IO() -showArchiveCompare archive1 archive2= do - val <- compareFiles archive1 archive2 - putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ show val - -showAcidQuery :: FilePath -> HackageName -> IO() -showAcidQuery updateDir name = do - putStrLn $ "Querying acid with " ++ name - value <- queryAcidMap updateDir name - case value of - Just package -> do - putStrLn "Found" - print package - Nothing -> putStrLn "Not found" + 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 exitREPL :: IO() -exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess - --- this method cuts the data from the end of the archive --- needed mostly for testing purposes -cutFile :: FilePath -> Int64 -> IO() -cutFile path size = do - truncateIfExists path size - putStrLn $ "Cut " ++ show size ++ " bytes from " ++ path - -unzipArchive :: FilePath -> FilePath -> IO() -unzipArchive archive tar = do - putStrLn $ "Unzipping " ++ archive ++ " to " ++ tar - unzipFile archive tar - -removeArchiveFiles :: FilePath -> FilePath -> IO() -removeArchiveFiles archive tar = do - putStrLn $ "Removing archive files " ++ archive ++ " " ++ tar - removeIfExists archive - removeIfExists tar - -printAcidCompare :: FilePath -> FilePath -> IO() -printAcidCompare updateDir tarFile = do - newTar <- loadTar tarFile - let newMap = buildHackageMap newTar (buildPreHackageMap newTar) - printAcidDiffMap updateDir newMap - -acidUpdate :: FilePath -> FilePath -> IO() -acidUpdate updateDir tarFile = do - newTar <- loadTar tarFile - let newMap = buildHackageMap newTar (buildPreHackageMap newTar) - updateAcidMap updateDir newMap - -updateArchive :: HackageUpdateInfo -> IO() -updateArchive iuh = void (performArchiveFileUpdate snapURL archURL arch) - where - arch = getArchive iuh - archURL = iuhArchiveURL iuh - snapURL = iuhSnapshotURL iuh - -updateMapFromTar :: HackageUpdateInfo -> IO() -updateMapFromTar iuh = acidUpdate (iuhUpdateDir iuh) (getTar iuh) - -queryHackageMap :: HackageUpdateInfo -> HackageName -> IO (Maybe HackagePackage) -queryHackageMap iuh = queryAcidMap (iuhUpdateDir iuh) - - - - - - - +exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess \ No newline at end of file diff --git a/REPL/src/Stackage.hs b/REPL/src/Stackage.hs index 7294161..0a8bc10 100644 --- a/REPL/src/Stackage.hs +++ b/REPL/src/Stackage.hs @@ -19,21 +19,11 @@ import Control.Applicative(empty) import Common type ConstraintMap = M.Map PackageName PackageData -type ShortSnapshotName = String -type LongSnapshotName = String -type StackageSnapshot = (ShortSnapshotName, LongSnapshotName) - -shortName :: StackageSnapshot -> String -shortName = fst - -longName :: StackageSnapshot -> String -longName = snd - -type StackageLTS = (LongSnapshotName, [PackageData]) parseStackageLTS :: Parser StackageLTS parseStackageLTS = do ltsName <- parseLTS + eol manyTill anyChar (string "constraints:") packages <- many parsePackageLine pure (ltsName, packages) @@ -52,7 +42,7 @@ parsePackageLine = do version <- parseVersionVer many (char ',') space - pure (name, version) + pure (name, Specified version) -- unfortunately the cabal.config does not provide versions for several packages -- And writes tehn in form 'binary installed' diff --git a/REPL/src/StackageCommands.hs b/REPL/src/StackageCommands.hs new file mode 100644 index 0000000..974f787 --- /dev/null +++ b/REPL/src/StackageCommands.hs @@ -0,0 +1,11 @@ +module StackageCommands( + showSnapshots) where + +import Common +import StackageUpdate + +showSnapshots :: URL -> IO() +showSnapshots url = do + SSS snapshots <- fetchStackageSnapshots url + putStrLn $ "Showing snapshots from " ++ url + mapM_ (putStrLn.(\s -> "\tSnapshot: " ++ s).show) snapshots \ No newline at end of file diff --git a/REPL/src/StackageUpdate.hs b/REPL/src/StackageUpdate.hs new file mode 100644 index 0000000..302d0d9 --- /dev/null +++ b/REPL/src/StackageUpdate.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module StackageUpdate(fetchStackageSnapshots) where + +import Data.Traversable +import Data.Aeson.Types +import qualified Data.Aeson as A +import qualified Data.Aeson.Parser as AP +import qualified Data.Text as T +import qualified Control.Exception as X +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import Network.HTTP.Client(parseUrlThrow) + +import Common +import HttpDownload + +instance FromJSON StackageSnapshots where + parseJSON = withObject "snapshots" $ \o -> + -- I have 'o', which is a HashMap. + SSS <$> (for (HM.toList o) $ \(shortName, longNameVal) -> do + longName <- parseJSON longNameVal + return (T.unpack shortName, longName)) + +-- The method, that raises an exception, if it was not able to parse the +-- snapshot from JSON +parseSnapshotJSONThrow :: BL.ByteString -> IO StackageSnapshots +parseSnapshotJSONThrow body = case A.decode body of + (Just snapshots) -> return snapshots + Nothing -> X.throwIO $ UAE "Could not decode stackage JSON" + +fetchStackageSnapshots :: URL -> IO StackageSnapshots +fetchStackageSnapshots url = parseUrlThrow url >>= fetchResponseData >>= parseSnapshotJSONThrow + +{- +parseReferers :: Value -> Parser StackageSnapshots +parseReferers = withObject "referers" $ \o -> + -- Now we have 'o', which is a HashMap. We can use HM.toList to turn it + -- into a list of pairs (domain, referer) and then parse each referer: + for (HM.toList o) $ \(domain, referer) -> do + -- accesses :: [(Text, Int)] + accesses <- HM.toList <$> parseJSON referer + -- accesses' :: [(String, Int)] + let accesses' = map (\(page, n) -> (T.unpack page, n)) accesses + return $ Referer { + domain = T.unpack domain, + pathAccesses = accesses' } +-} \ No newline at end of file diff --git a/REPL/src/Storage.hs b/REPL/src/Storage.hs deleted file mode 100644 index 5cb19b0..0000000 --- a/REPL/src/Storage.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - --- This is modified example from AcidState -module Storage ( - printAcidDiffMap, - updateAcidMap, - queryAcidMap) where - -import Data.Typeable -import Data.Acid -import Data.Acid.Advanced -import Data.SafeCopy -import Control.Monad.Reader - -import qualified Data.Map as M -import qualified Control.Monad.State as State - -import HackageArchive -import qualified Data.Version as DV - -newtype KeyValue = KeyValue HackageMap deriving (Typeable) - -$(deriveSafeCopy 0 'base ''DV.Version) -$(deriveSafeCopy 0 'base ''HackagePackage) -$(deriveSafeCopy 0 'base ''KeyValue) -$(deriveSafeCopy 0 'base ''HackageUpdate) - -insertKey :: HackageName -> HackagePackage -> Update KeyValue () -insertKey key value = do - KeyValue hackageMap <- State.get - State.put (KeyValue (M.insert key value hackageMap)) - -updateMap :: HackageMap -> Update KeyValue () -updateMap newMap = State.put (KeyValue newMap) - -lookupKey :: HackageName -> Query KeyValue (Maybe HackagePackage) -lookupKey key = do - KeyValue m <- ask - return (M.lookup key m) - -compareMap :: HackageMap -> Query KeyValue HackageUpdateMap -compareMap newMap = do - KeyValue oldMap <- ask - return (buildDifferenceMap oldMap newMap) - -$(makeAcidic ''KeyValue ['insertKey, 'lookupKey, 'compareMap, 'updateMap]) - -printAcidDiffMap :: FilePath -> HackageMap -> IO () -printAcidDiffMap path newMap = do - acid <- openLocalStateFrom path (KeyValue M.empty) - do - diffMap <- query acid (CompareMap newMap) - putStrLn "Printing difference map with acid-state" - mapM_ (print.snd) $ M.toList diffMap - closeAcidState acid - -updateAcidMap :: FilePath -> HackageMap -> IO () -updateAcidMap path newMap = do - acid <- openLocalStateFrom path (KeyValue M.empty) - do - putStrLn "Updating the acid map" - update acid (UpdateMap newMap) - closeAcidState acid - -queryAcidMap :: FilePath -> HackageName -> IO (Maybe HackagePackage) -queryAcidMap path name = do - acid <- openLocalStateFrom path (KeyValue M.empty) - val <- query acid (LookupKey name) - closeAcidState acid - return val - diff --git a/REPL/test/Spec.hs b/REPL/test/Spec.hs index c3e4e75..7c3eb0f 100644 --- a/REPL/test/Spec.hs +++ b/REPL/test/Spec.hs @@ -31,14 +31,6 @@ testPath text val match = testCase (T.unpack ("Parsing " <> expect match <> " \' parseStackageTests = testGroup "Stackage parsing tests" [ -{- - testParse parsePackageLine "constraints: abstract-deque ==0.3," True - , testParse parsePackageLine "constraints: abstract-deque ==0.3" True - , testParse parsePackageLine "constraints: abstract-deque ==0." False - , testParse parsePackageLine "constraints: abstract-deque ==" False - , testParse parsePackageLine "constraints: abst3453#$%#ract-deque ==0.3" False - , testParse parsePackageLine "constraints: abstract-deque ==0.3," True --} testParse parsePackageLine " ztail ==1.2" True , testParse parsePackageLine " adjunctions ==4.3," True , testParse parsePackageLine "ztail ==1.2" True @@ -57,18 +49,27 @@ parseStackageTests = testGroup "Stackage parsing tests" parseCabalConfig = testGroup "Cabal config parsing tests" [ - testStackagePackageLines "sometestfile.cnf" + testStackagePackageLines parseStackageLTS "sometestfile.cnf" + , testStackagePackageLines parseStackageLTS "sometestfile2.cnf" + , testFileJustParse parseStackageLTS "sometestfile3.cnf" True ] -testStackagePackageLines file = testFileParse (testWorkingDir file) - parseStackageLTS countPackageLines matchWithStackageLTS +-- Well this is code duplication. Somehow need to use testParse function here +testFileJustParse :: Parser a -> FilePath -> Bool -> TestTree +testFileJustParse p file match = testCase ("Testing file: " ++ file) $ do + fileText <- TIO.readFile (testWorkingDir file) + assertBool "Failed" (isRight (runParser p "" fileText) == match) + +testStackagePackageLines :: Parser StackageLTS -> FilePath -> TestTree +testStackagePackageLines p file = testFileParse (testWorkingDir file) + p countPackageLines matchWithStackageLTS --- refactor isComment countPackageLines :: T.Text -> Int -countPackageLines text = length $ filter isComment lns +countPackageLines text = length $ filter isPackageLine lns where lns = T.lines text - isComment ln = not ("--" `T.isInfixOf` ln) + isPackageLine ln = not ("--" `T.isInfixOf` ln) + && (("installed" `T.isInfixOf` ln) || ("==" `T.isInfixOf` ln)) matchWithStackageLTS :: Int -> StackageLTS -> Bool matchWithStackageLTS count1 stackage = count1 == (length.snd) stackage diff --git a/REPL/testworkdir/sometestfile2.cnf b/REPL/testworkdir/sometestfile2.cnf new file mode 100644 index 0000000..55245c9 --- /dev/null +++ b/REPL/testworkdir/sometestfile2.cnf @@ -0,0 +1,12 @@ +-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.10 +-- Please place this file next to your .cabal file as cabal.config +-- To only use tested packages, uncomment the following line: +-- remote-repo: stackage-lts-2.10:http://www.stackage.org/lts-2.10 +constraints: abstract-deque ==0.3, + + + + + + + \ No newline at end of file diff --git a/REPL/testworkdir/sometestfile3.cnf b/REPL/testworkdir/sometestfile3.cnf new file mode 100644 index 0000000..2396158 --- /dev/null +++ b/REPL/testworkdir/sometestfile3.cnf @@ -0,0 +1,12 @@ +-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.10ZZZ +-- Please place this file next to your .cabal file as cabal.config +-- To only use tested packages, uncomment the following line: +-- remote-repo: stackage-lts-2.10:http://www.stackage.org/lts-2.10 +constraints: abstract-deque ==0.3, + + + + + + + \ No newline at end of file