diff --git a/REPL/src/AllCommands.hs b/REPL/src/AllCommands.hs index 9618cb8..889e244 100644 --- a/REPL/src/AllCommands.hs +++ b/REPL/src/AllCommands.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module AllCommands( UpdateInfo(..), CombinedPackage (..), @@ -30,9 +32,12 @@ defaultUI = UI { newtype CombinedPackage = CP (HA.HackagePackage, Maybe SA.StackagePackage) deriving (Eq) 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" - + show (CP (hp, sp)) = packageName ++ " " ++ show packageVersion ++ present + where + PackageId{..} = HA.package hp + present = case sp of + Just _ -> " present in stackage" + Nothing -> " not in stackage" queryCombinedData :: UpdateInfo -> PackageName -> IO (Maybe CombinedPackage) queryCombinedData ui package = do @@ -86,4 +91,4 @@ transformS sCommand = RC { allCommands :: [REPLCommand UpdateInfo] allCommands = updateAllCommand : showQueryCombinedDataCommand : - map transformH HC.hackageCommands ++ map transformS SC.stackageCommands \ No newline at end of file + map transformH HC.hackageCommands ++ map transformS SC.stackageCommands diff --git a/REPL/src/Common.hs b/REPL/src/Common.hs index f77bc30..7be1e1a 100644 --- a/REPL/src/Common.hs +++ b/REPL/src/Common.hs @@ -1,78 +1,70 @@ -module Common(URL, - PackageName, - PackageData, - PackageDatum(..), - SnapshotData(..), - UpdateArchiveException(..), - parseIntEnd, - parseValEnd, - - ShortSnapshotName, - LongSnapshotName, - shortName, - longName, - StackageSnapshot, - StackageSnapshots(..), - getNormalSnapshots, - filterNormal, - StackageLTS) where +module Common +( + URL, + PackageName, + PackageId(..), + SnapshotData(..), + UpdateArchiveException(..), + parseIntEnd, + parseValEnd, + + SnapshotName, + SnapshotId(..), + filterLTS, + StackageLTS, +) +where + import qualified Control.Exception as X -import qualified Data.ByteString.Lazy as BL -import qualified Data.List as DL +import Data.List + +import Data.Version +import Data.Int -import Data.Version as DV -import Data.Int(Int64) type URL = String + type PackageName = String -type PackageData = (PackageName, DV.Version) + +data PackageId = PackageId { + packageName :: PackageName, + packageVersion :: Version + } deriving (Eq, Show) data SnapshotData = SnapshotData { md5Hash :: String, lengthFile :: Int64 -} deriving (Eq, Show) + } + deriving (Eq, Show) --- The exception, that is raised, when there is problems with creating the +-- The exception that is raised when there are problems with creating the -- snapshot newtype UpdateArchiveException = UAE String deriving (Show, Eq) instance X.Exception UpdateArchiveException --- the constructor short name is really awkward in russian - - parseIntEnd :: (Num a, Read a) => String -> a -parseIntEnd val | not (null l) = read (DL.last l) +parseIntEnd val | not (null l) = read (last l) | otherwise = 0 where l = words val parseValEnd :: String -> String -parseValEnd val | DL.length l > 1 = DL.last l +parseValEnd val | length l > 1 = last l | otherwise = "" where l = words val +type SnapshotName = String --- Stackage stuff -type ShortSnapshotName = String -type LongSnapshotName = String -type StackageSnapshot = (ShortSnapshotName, LongSnapshotName) -newtype StackageSnapshots = SSS [StackageSnapshot] deriving (Eq, Show) +data SnapshotId = SnapshotId { + snapshotName :: SnapshotName, -- ^ E.g. “lts-8.23” or “nightly-2017-07-21” + snapshotGroup :: String -- ^ E.g. “lts-8” or “nightly” + } + deriving (Eq, Show) -filterNormal :: StackageSnapshots -> StackageSnapshots -filterNormal (SSS ss) = SSS (filter (\(_, l) -> DL.isPrefixOf "lts" l) ss) +filterLTS :: [SnapshotId] -> [SnapshotId] +filterLTS = filter (isPrefixOf "lts-" . snapshotName) -getSnapshots :: StackageSnapshots -> [StackageSnapshot] -getSnapshots (SSS ss) = ss - -getNormalSnapshots :: StackageSnapshots -> [StackageSnapshot] -getNormalSnapshots = getSnapshots.filterNormal - -newtype PackageDatum = PD [PackageData] deriving (Eq, Show) - -shortName :: StackageSnapshot -> String -shortName = fst - -longName :: StackageSnapshot -> String -longName = snd - -type StackageLTS = (LongSnapshotName, [PackageData]) \ No newline at end of file +data StackageLTS = StackageLTS { + snapshot :: SnapshotId, + packages :: [PackageId] + } deriving (Eq, Show) diff --git a/REPL/src/HackageArchive.hs b/REPL/src/HackageArchive.hs index a6a77f2..32fe859 100644 --- a/REPL/src/HackageArchive.hs +++ b/REPL/src/HackageArchive.hs @@ -52,10 +52,9 @@ import Common -- The record for each of the package from hackage -- TODO - add another information about the packages data HackagePackage = HP { - name :: PackageName, - pVersion :: DV.Version, - author :: String -} deriving (Eq, Show) + package :: PackageId, + author :: String + } deriving (Eq, Show) -- The status of the package between two updates data HackageUpdate = Added | Removed | Updated deriving (Eq, Show) @@ -65,11 +64,11 @@ data HackageUpdate = Added | Removed | Updated deriving (Eq, Show) type HackageMap = M.Map PackageName HackagePackage type PreHackageMap = M.Map PackageName DV.Version --- The map, that shows, which packages have change since the last update +-- The map that shows, for each package, which packages have change since the last update type HackageUpdateMap = M.Map PackageName (HackageUpdate, HackagePackage) -- Parses the file path of the cabal file to get version and package name -parseCabalFilePath :: RP.ReadP PackageData +parseCabalFilePath :: RP.ReadP PackageId parseCabalFilePath = do package <- RP.munch1 phi RP.char '/' @@ -79,7 +78,7 @@ parseCabalFilePath = do guard (name == package) suff <- RP.string ".cabal" RP.eof - pure (package, version) + pure (PackageId name version) where phi l = DC.isLetter l || l == '-' updateMapCompare :: (Ord a) => String -> a -> M.Map String a -> M.Map String a @@ -100,14 +99,14 @@ 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, pVersion = ver, author = auth } +createPackage pd = HP { package = PackageId name ver, author = auth } where pkg = DPD.package pd - nm = DP.unPackageName (DP.pkgName pkg) + name = DP.unPackageName (DP.pkgName pkg) ver = DP.pkgVersion pkg auth = DPD.author pd -parsePath :: FilePath -> Maybe PackageData +parsePath :: FilePath -> Maybe PackageId parsePath path = case RP.readP_to_S parseCabalFilePath path of [(pd, _)] -> Just pd _ -> Nothing @@ -121,12 +120,13 @@ parsePackageDescription _ = Nothing parsePackage :: Tar.Entry -> Maybe HackagePackage parsePackage entry = do - (path, version) <- parsePath $ Tar.entryPath entry + -- XXX: why do we parse it and then ignore it? + _ <- parsePath $ Tar.entryPath entry pd <- parsePackageDescription $ Tar.entryContent entry return $ createPackage pd -updatePreMap :: PackageData -> PreHackageMap -> PreHackageMap -updatePreMap (name, version) = updateMapCompare name version +updatePreMap :: PackageId -> PreHackageMap -> PreHackageMap +updatePreMap (PackageId name version) = updateMapCompare name version buildPreHackageMap :: Tar.Entries Tar.FormatError -> PreHackageMap buildPreHackageMap (Tar.Next entry entries) = @@ -141,11 +141,11 @@ buildPrehackageMap (Tar.Fail e) = X.throw e buildHackageMap :: Tar.Entries Tar.FormatError -> PreHackageMap -> HackageMap buildHackageMap (Tar.Next entry entries) premap = case update $ Tar.entryPath entry of - Just hp -> M.insert (name hp) hp map + Just hp -> M.insert (packageName (package hp)) hp map Nothing -> map where map = buildHackageMap entries premap update path = do - (name, version) <- parsePath path + PackageId name version <- parsePath path preversion <- M.lookup name premap if preversion == version then parsePackage entry else Nothing @@ -157,6 +157,7 @@ buildHackageMap (Tar.Fail e) _ = X.throw e newtype KeyValue = KeyValue HackageMap deriving (Typeable) $(deriveSafeCopy 0 'base ''DV.Version) +$(deriveSafeCopy 0 'base ''PackageId) $(deriveSafeCopy 0 'base ''HackagePackage) $(deriveSafeCopy 0 'base ''KeyValue) $(deriveSafeCopy 0 'base ''HackageUpdate) @@ -205,4 +206,3 @@ queryPersistentMap path name = do 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 index e833220..13e0505 100644 --- a/REPL/src/HackageCommands.hs +++ b/REPL/src/HackageCommands.hs @@ -357,4 +357,4 @@ updateAllHackageCommand = RC { 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/StackageArchive.hs b/REPL/src/StackageArchive.hs index ba83f7a..1818420 100644 --- a/REPL/src/StackageArchive.hs +++ b/REPL/src/StackageArchive.hs @@ -28,13 +28,13 @@ import Common import StackageUpdate -- This is a mapping of version of the package, that is present in the lts --- snapshot with the specified name. So -newtype StackageVersionLTS = SVL (M.Map LongSnapshotName DV.Version) deriving (Eq) +-- snapshot with the specified name. +newtype StackageVersionLTS = SVL (M.Map SnapshotName DV.Version) deriving (Eq) instance Show StackageVersionLTS where show (SVL map) = "LTS versions\n" ++ concatMap (\(n, v) -> n ++ " " ++ show v ++ "\n") (M.toList map) -makeSVL :: LongSnapshotName -> DV.Version -> StackageVersionLTS +makeSVL :: SnapshotName -> DV.Version -> StackageVersionLTS makeSVL ss v = SVL $ M.singleton ss v data StackagePackage = SP { @@ -45,33 +45,34 @@ data StackagePackage = SP { instance Show StackagePackage where show (SP name versions) = "SP " ++ name ++ "\n" ++ show versions -addSVL :: StackagePackage -> LongSnapshotName -> DV.Version -> StackagePackage +addSVL :: StackagePackage -> SnapshotName -> DV.Version -> StackagePackage addSVL (SP n (SVL m)) name version = SP n $ SVL $ M.insert name version m type StackageMap = M.Map PackageName StackagePackage -updateStackageMap :: StackageMap -> LongSnapshotName -> PackageDatum -> StackageMap -updateStackageMap map snapshotName (PD packages) = +updateStackageMap :: StackageMap -> SnapshotName -> [PackageId] -> StackageMap +updateStackageMap map snapshotName packages = foldr (\p m -> updateStackageMapPackage m snapshotName p) map packages -updateStackageMapPackage :: StackageMap -> LongSnapshotName -> PackageData -> StackageMap -updateStackageMapPackage map snapshot (package, version) = case M.lookup package map of - -- The package is present in map, extend it's knoledge by adding new snapshot info - -- into it's map +updateStackageMapPackage :: StackageMap -> SnapshotName -> PackageId -> StackageMap +updateStackageMapPackage map snapshot (PackageId package version) = + case M.lookup package map of + -- The package is present in map, extend it's knoledge by adding new + -- snapshot info into its map Just sp -> M.update (\sp -> Just $ addSVL sp snapshot version) package map -- well, no package is present. Create one from scratch Nothing -> M.insert package (SP package (makeSVL snapshot version)) map -generateStackageMap :: FilePath -> StackageSnapshots -> IO StackageMap +generateStackageMap :: FilePath -> [SnapshotId] -> IO StackageMap -- make the empty map here -generateStackageMap _ (SSS []) = return M.empty -generateStackageMap filePath (SSS (s: xs)) = do +generateStackageMap _ [] = return M.empty +generateStackageMap filePath (s:xs) = do -- get the yaml file - body <- BS.readFile (filePath longName s ++ ".yaml") - newMap <- generateStackageMap filePath $ SSS xs + body <- BS.readFile (filePath snapshotName s ++ ".yaml") + newMap <- generateStackageMap filePath xs -- build the map from this yaml file - pkgDatum <- parseYamlFileThrow body - return $ updateStackageMap newMap (longName s) pkgDatum + SnapshotInfo core other <- parseSnapshotInfo body + return $ updateStackageMap newMap (snapshotName s) (core ++ other) -- this is needed for acid serialization newtype KeyValue = KeyValue StackageMap deriving (Typeable) @@ -99,9 +100,8 @@ $(makeAcidic ''KeyValue ['insertKey, 'lookupKey, 'updateMap]) updatePersistentMap :: FilePath -> StackageMap -> IO () updatePersistentMap path newMap = do acid <- openLocalStateFrom path (KeyValue M.empty) - do - putStrLn "Updating the persistent map" - update acid (UpdateMap newMap) + putStrLn "Updating the persistent map" + update acid (UpdateMap newMap) closeAcidState acid queryPersistentMap :: FilePath -> PackageName -> IO (Maybe StackagePackage) diff --git a/REPL/src/StackageCommands.hs b/REPL/src/StackageCommands.hs index 350d91a..72c699c 100644 --- a/REPL/src/StackageCommands.hs +++ b/REPL/src/StackageCommands.hs @@ -14,19 +14,20 @@ import qualified Data.ByteString as BS import qualified Data.Map.Strict as M import System.FilePath(()) import Data.Default +import Data.Foldable (for_) import Common import StackageUpdate import StackageArchive import REPL -getLTSStackageURL :: StackageUpdateInfo -> LongSnapshotName -> URL +getLTSStackageURL :: StackageUpdateInfo -> SnapshotName -> 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 :: StackageUpdateInfo -> SnapshotName -> URL getLTSGithubURL sui name = suiLTSURL sui (name ++ ".yaml") getLTSFilesDir :: StackageUpdateInfo -> FilePath @@ -66,9 +67,10 @@ stackageCommands = [ showSnapshots :: URL -> IO () showSnapshots url = do - SSS snapshots <- fetchStackageSnapshots url + snapshots <- fetchStackageSnapshots url putStrLn $ "Showing snapshots from " ++ url - mapM_ (putStrLn.(\s -> "\tSnapshot: " ++ s).show) snapshots + for_ snapshots $ \snapshot -> + putStrLn ("\tSnapshot: " ++ show snapshot) showSnapshotsCommand :: REPLCommand StackageUpdateInfo showSnapshotsCommand = RC { @@ -82,14 +84,14 @@ showLTSContents :: FilePath -> IO () showLTSContents ltsFile = do putStrLn $ "Showing the contents of " ++ ltsFile body <- BS.readFile ltsFile - datum <- parseYamlFileThrow body + datum <- parseSnapshotInfo 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), + cExec = \sui commandStr -> let lts = parseValEnd commandStr in showLTSContents (getLTSFile sui lts), cDescription = const "ltsshowcont lts - shows the contents of specified downloaded lts file" } @@ -110,7 +112,7 @@ updateLTSFileCommand = RC { updateAllLTSFiles :: FilePath -> URL -> URL -> IO () updateAllLTSFiles ltsDir ltsURL snapshotsURL = do snapshots <- fetchStackageSnapshots snapshotsURL - fetchAllLTSFiles ltsDir ltsURL (filterNormal snapshots) + fetchAllLTSFiles ltsDir ltsURL (filterLTS snapshots) updateAllLTSFilesCommand :: REPLCommand StackageUpdateInfo updateAllLTSFilesCommand = RC { @@ -126,9 +128,9 @@ showStackageMapContents ltsDir ltsURL snapshotsURL count = do putStrLn "Fetching snapshot lists" snapshots <- fetchStackageSnapshots snapshotsURL putStrLn "Downloading YAML files" - fetchAllLTSFiles ltsDir ltsURL (filterNormal snapshots) + fetchAllLTSFiles ltsDir ltsURL (filterLTS snapshots) putStrLn "Generating stackage map" - map <- generateStackageMap ltsDir (filterNormal snapshots) + map <- generateStackageMap ltsDir (filterLTS snapshots) putStrLn $ "Printing " ++ show count ++ " packages" mapM_ print $ take count $ M.toList map @@ -147,9 +149,9 @@ updatePersistentMapFromLTS updateDir ltsDir ltsURL snapshotsURL = do putStrLn "Fetching snapshot lists" snapshots <- fetchStackageSnapshots snapshotsURL putStrLn "Downloading YAML files" - fetchAllLTSFiles ltsDir ltsURL (filterNormal snapshots) + fetchAllLTSFiles ltsDir ltsURL (filterLTS snapshots) putStrLn "Generating stackage map" - map <- generateStackageMap ltsDir (filterNormal snapshots) + map <- generateStackageMap ltsDir (filterLTS snapshots) updatePersistentMap updateDir map updatePersistentMapFromLTSCommand :: REPLCommand StackageUpdateInfo diff --git a/REPL/src/StackageUpdate.hs b/REPL/src/StackageUpdate.hs index bc65c94..d5aaff6 100644 --- a/REPL/src/StackageUpdate.hs +++ b/REPL/src/StackageUpdate.hs @@ -1,15 +1,24 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module StackageUpdate(fetchStackageSnapshots, - fetchLTS, - fetchAllLTSFiles, - parseYamlFileThrow) where +module StackageUpdate +( + SnapshotInfo(..), + fetchStackageSnapshots, + fetchLTS, + fetchAllLTSFiles, + parseSnapshotInfo, +) +where +import Data.Foldable import Data.Traversable -import Data.Aeson.Types -import qualified Data.Aeson as A -import qualified Data.Aeson.Parser as AP +import Data.Aeson +-- import qualified Data.Aeson as A +import qualified Data.Aeson.Parser as A +import qualified Data.Aeson.Types as A import qualified Text.Megaparsec as TM import qualified Text.Megaparsec.String as TMS @@ -30,21 +39,19 @@ import Common import HttpDownload import FileUtils -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" +parseSnapshotJSONThrow :: BL.ByteString -> IO [SnapshotId] +parseSnapshotJSONThrow body = + case A.decodeWith A.json (A.parse parser) body of + Just snapshots -> return snapshots + Nothing -> X.throwIO $ UAE "Could not decode stackage JSON" + where + parser v = do + pairs <- HM.toList <$> parseJSON v + pure $ map (\(snapshotGroup, snapshotName) -> SnapshotId{..}) pairs -fetchStackageSnapshots :: URL -> IO StackageSnapshots +fetchStackageSnapshots :: URL -> IO [SnapshotId] fetchStackageSnapshots url = parseUrlThrow url >>= fetchResponseData >>= parseSnapshotJSONThrow fetchLTS :: FilePath -> URL -> IO () @@ -54,45 +61,49 @@ fetchLTS file url = do createDirectoryIfMissing True (takeDirectory file) writeAll2File file url -fetchAllLTSFiles :: FilePath -> URL -> StackageSnapshots -> IO() -fetchAllLTSFiles dir url (SSS ss) = do +fetchAllLTSFiles :: FilePath -> URL -> [SnapshotId] -> IO() +fetchAllLTSFiles dir url ss = do putStrLn $ "Getting all LTS from " ++ url ++ " to directory " ++ dir createDirectoryIfMissing True dir - mapM_ (\(_, l) -> fetchLTS (mkyml dir l) (mkyml url l)) ss + for_ ss $ \SnapshotId{..} -> + fetchLTS (mkyml dir snapshotName) (mkyml url snapshotName) where mkyml pth l = pth (l ++ ".yaml") -parseYamlFileThrow :: BS.ByteString -> IO PackageDatum -parseYamlFileThrow body = case Y.decode body of - (Just datum) -> return datum - Nothing -> X.throwIO $ UAE "Could not decode package data yaml" +-- | Parse a snapshot description file (e.g. +-- ) +parseSnapshotInfo :: BS.ByteString -> IO SnapshotInfo +parseSnapshotInfo body = case Y.decode body of + Just datum -> return datum + Nothing -> X.throwIO $ UAE "Could not decode package data yaml" +data SnapshotInfo = SnapshotInfo { + snapshotCorePackages :: [PackageId], + snapshotOtherPackages :: [PackageId] + } deriving (Eq, Show) -- This is the data, that is extracted from the yaml file -instance FromJSON PackageDatum where - parseJSON = withObject "bigfatyaml" $ \o -> do - systemO <- o .: "system-info" - coreO <- systemO .: "core-packages" - - pkgCore <- for (HM.toList coreO) $ \(name :: String, versionStr :: String) -> do +instance FromJSON SnapshotInfo where + parseJSON = withObject "SnapshotInfo" $ \o -> do + core <- o .: "system-info" >>= (.: "core-packages") + snapshotCorePackages <- for (HM.toList core) $ \(name, versionStr) -> do version <- parseV versionStr - return (name, version) + return (PackageId name version) - packagesO <- o .: "packages" - - pkgAll <- for (HM.toList packagesO) $ \(name :: String, content) -> do - (versionStr :: String) <- content .: "version" + packages <- o .: "packages" + snapshotOtherPackages <- for (HM.toList packages) $ \(name, content) -> do + versionStr <- content .: "version" version <- parseV versionStr - return (name, version) + return (PackageId name version) - return $ PD (pkgCore ++ pkgAll) + return $ SnapshotInfo{..} where - parseV vstr = case TM.parseMaybe parseVersion vstr of - Just version -> return version - Nothing -> fail "Count not parse" + parseV vstr = case TM.parseMaybe parseVersion vstr of + Just version -> return version + Nothing -> fail "Count not parse" parseVersion :: TMS.Parser DV.Version parseVersion = do @@ -126,4 +137,4 @@ parsePackageLine = do many (char ',') space pure (name, version) --} \ No newline at end of file +-}