aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-12-22 20:31:31 +03:00
Code Issues Projects Releases Wiki Activity

[hackagerepl] Some refactoring & name changes

Browse Source
This commit is contained in:
Artyom 2017-08-18 03:08:24 +03:00
parent 29f879962e
commit fa8f7e9cd2
No known key found for this signature in database
GPG Key ID: B8E35A33FF522710
7 changed files with 157 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
REPL/src/AllCommands.hs
View File

@ -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

84
REPL/src/Common.hs
View File

@ -1,78 +1,70 @@
module Common(URL,
module Common
(
URL,
PackageName,
PackageData,
PackageDatum(..),
PackageId(..),
SnapshotData(..),
UpdateArchiveException(..),
parseIntEnd,
parseValEnd,
ShortSnapshotName,
LongSnapshotName,
shortName,
longName,
StackageSnapshot,
StackageSnapshots(..),
getNormalSnapshots,
filterNormal,
StackageLTS) where
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])
data StackageLTS = StackageLTS {
snapshot :: SnapshotId,
packages :: [PackageId]
} deriving (Eq, Show)

28
REPL/src/HackageArchive.hs
View File

@ -52,8 +52,7 @@ 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,
package :: PackageId,
author :: String
} 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

36
REPL/src/StackageArchive.hs
View File

@ -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,7 +100,6 @@ $(makeAcidic ''KeyValue ['insertKey, 'lookupKey, 'updateMap])
updatePersistentMap :: FilePath -> StackageMap -> IO ()
updatePersistentMap path newMap = do
acid <- openLocalStateFrom path (KeyValue M.empty)
do
putStrLn "Updating the persistent map"
update acid (UpdateMap newMap)
closeAcidState acid

22
REPL/src/StackageCommands.hs
View File

@ -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,7 +84,7 @@ 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
@ -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

81
REPL/src/StackageUpdate.hs
View File

@ -1,15 +1,24 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module StackageUpdate(fetchStackageSnapshots,
module StackageUpdate
(
SnapshotInfo(..),
fetchStackageSnapshots,
fetchLTS,
fetchAllLTSFiles,
parseYamlFileThrow) where
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
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,40 +61,44 @@ 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
-- | Parse a snapshot description file (e.g.
-- <https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-8.9.yaml>)
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