[hackagerepl] Some refactoring & name changes

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, sp)) = packageName ++ " " ++ show packageVersion ++ present
-  show (CP (hp, Nothing)) = HA.name hp ++ " " ++ show (HA.pVersion hp) ++ " not in stackage" 
+    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

REPL/src/Common.hs

@@ -1,78 +1,70 @@
-module Common(URL,
+module Common
-              PackageName,
+(
-              PackageData,
+  URL,
-              PackageDatum(..),
+  PackageName,
-              SnapshotData(..),
+  PackageId(..),
-              UpdateArchiveException(..),
+  SnapshotData(..),
-              parseIntEnd,
+  UpdateArchiveException(..),
-              parseValEnd,
+  parseIntEnd,
+  parseValEnd,
+
+  SnapshotName,
+  SnapshotId(..),
+  filterLTS,
+  StackageLTS,
+)
+where
 
-              ShortSnapshotName,
-              LongSnapshotName,
-              shortName,
-              longName,
-              StackageSnapshot,
-              StackageSnapshots(..), 
-              getNormalSnapshots,
-              filterNormal,
-              StackageLTS) where
 
 import qualified Control.Exception as X
-import qualified Data.ByteString.Lazy as BL
+import Data.List
-import qualified Data.List as DL
+
+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
+data SnapshotId = SnapshotId {
-type ShortSnapshotName = String
+  snapshotName  :: SnapshotName,  -- ^ E.g. “lts-8.23” or “nightly-2017-07-21”
-type LongSnapshotName = String
+  snapshotGroup :: String         -- ^ E.g. “lts-8” or “nightly”
-type StackageSnapshot = (ShortSnapshotName, LongSnapshotName)
+  }
-newtype StackageSnapshots = SSS [StackageSnapshot] deriving (Eq, Show)
+  deriving (Eq, Show)
 
-filterNormal :: StackageSnapshots -> StackageSnapshots
+filterLTS :: [SnapshotId] -> [SnapshotId]
-filterNormal (SSS ss) = SSS (filter (\(_, l) -> DL.isPrefixOf "lts" l) ss)
+filterLTS = filter (isPrefixOf "lts-" . snapshotName)
 
-getSnapshots :: StackageSnapshots -> [StackageSnapshot] 
+data StackageLTS = StackageLTS {
-getSnapshots (SSS ss) = ss
+  snapshot :: SnapshotId,
-
+  packages :: [PackageId]
-getNormalSnapshots :: StackageSnapshots -> [StackageSnapshot]
+  } deriving (Eq, Show)
-getNormalSnapshots = getSnapshots.filterNormal
-
-newtype PackageDatum = PD [PackageData] deriving (Eq, Show)
-
-shortName :: StackageSnapshot -> String
-shortName = fst
-
-longName :: StackageSnapshot -> String
-longName = snd
-
-type StackageLTS = (LongSnapshotName, [PackageData])

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,
+  package :: PackageId,
-  pVersion :: DV.Version,
+  author  :: String
-  author :: String
+  } deriving (Eq, Show)
-} 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 :: PackageId -> PreHackageMap -> PreHackageMap
-updatePreMap (name, version) = updateMapCompare name version
+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
-  

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 
+-- snapshot with the specified name.
-newtype StackageVersionLTS = SVL (M.Map LongSnapshotName DV.Version) deriving (Eq)
+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 :: StackageMap -> SnapshotName -> [PackageId] -> StackageMap
-updateStackageMap map snapshotName (PD packages) = 
+updateStackageMap map snapshotName packages = 
     foldr (\p m -> updateStackageMapPackage m snapshotName p) map packages
 
-updateStackageMapPackage :: StackageMap -> LongSnapshotName -> PackageData -> StackageMap
+updateStackageMapPackage :: StackageMap -> SnapshotName -> PackageId -> StackageMap
-updateStackageMapPackage map snapshot (package, version) = case M.lookup package map of
+updateStackageMapPackage map snapshot (PackageId package version) =
-    -- The package is present in map, extend it's knoledge by adding new snapshot info
+  case M.lookup package map of
-    -- into it's map
+    -- 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 _        []     = return M.empty 
-generateStackageMap filePath (SSS (s: xs)) = do
+generateStackageMap filePath (s:xs) = do
     -- get the yaml file
-    body <- BS.readFile (filePath </> longName s ++ ".yaml")
+    body <- BS.readFile (filePath </> snapshotName s ++ ".yaml")
-    newMap <- generateStackageMap filePath $ SSS xs
+    newMap <- generateStackageMap filePath xs
     -- build the map from this yaml file
-    pkgDatum <- parseYamlFileThrow body
+    SnapshotInfo core other <- parseSnapshotInfo body
-    return $ updateStackageMap newMap (longName s) pkgDatum
+    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"
-    putStrLn "Updating the persistent map"
+  update acid (UpdateMap newMap) 
-    update acid (UpdateMap newMap) 
   closeAcidState acid
 
 queryPersistentMap :: FilePath -> PackageName -> IO (Maybe StackagePackage)

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

REPL/src/StackageUpdate.hs

@@ -1,15 +1,24 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module StackageUpdate(fetchStackageSnapshots, 
+module StackageUpdate
-                      fetchLTS, 
+(
-                      fetchAllLTSFiles,
+  SnapshotInfo(..),
-                      parseYamlFileThrow) where
+  fetchStackageSnapshots,
+  fetchLTS,
+  fetchAllLTSFiles,
+  parseSnapshotInfo,
+)
+where
 
+import Data.Foldable
 import Data.Traversable
-import Data.Aeson.Types
+import Data.Aeson
-import qualified Data.Aeson as A
+-- import qualified Data.Aeson as A
-import qualified Data.Aeson.Parser as AP
+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 :: BL.ByteString -> IO [SnapshotId]
-parseSnapshotJSONThrow body = case A.decode body of 
+parseSnapshotJSONThrow body =
-  (Just snapshots) -> return snapshots
+  case A.decodeWith A.json (A.parse parser) body of
-  Nothing -> X.throwIO $ UAE "Could not decode stackage JSON"
+    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 :: FilePath -> URL -> [SnapshotId] -> IO()
-fetchAllLTSFiles dir url (SSS ss) = do
+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
+-- | Parse a snapshot description file (e.g.
-parseYamlFileThrow body = case Y.decode body of
+-- <https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-8.9.yaml>)
-  (Just datum) -> return datum
+parseSnapshotInfo :: BS.ByteString -> IO SnapshotInfo
-  Nothing -> X.throwIO $ UAE "Could not decode package data yaml"
+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
+instance FromJSON SnapshotInfo where
-  parseJSON = withObject "bigfatyaml" $ \o -> do
+  parseJSON = withObject "SnapshotInfo" $ \o -> do
-    systemO <- o .: "system-info"
+    core <- o .: "system-info" >>= (.: "core-packages")
-    coreO <- systemO .: "core-packages"
+    snapshotCorePackages <- for (HM.toList core) $ \(name, versionStr) -> do
-
-    pkgCore <- for (HM.toList coreO) $ \(name :: String, versionStr :: String) -> do
       version <- parseV versionStr
-      return (name, version)    
+      return (PackageId name version)
 
-    packagesO <- o .: "packages"
+    packages <- o .: "packages"
-
+    snapshotOtherPackages <- for (HM.toList packages) $ \(name, content) -> do 
-    pkgAll <- for (HM.toList packagesO) $ \(name :: String, content) -> do 
+      versionStr <- content .: "version"
-      (versionStr :: String) <- 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
+      parseV vstr = case TM.parseMaybe parseVersion vstr of
-            Just version -> return version
+        Just version -> return version
-            Nothing -> fail "Count not parse"
+        Nothing -> fail "Count not parse"
           
 parseVersion :: TMS.Parser DV.Version
 parseVersion = do