mirror of
https://github.com/aelve/guide.git
synced 2024-11-25 18:56:52 +03:00
Added stackage parsing. Refactored tests.
This commit is contained in:
Boris M. Yartsev
parent
b5c06150fb
commit
ebc0941571
@ -15,8 +15,8 @@ cabal-version: >=1.10
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
other-modules: Common, FileUtils, HttpDownload, HackageUpdate, HackageArchive, REPL, Storage, Stackage
|
||||
exposed-modules: IndexProject
|
||||
other-modules: Common, FileUtils, HttpDownload, HackageUpdate, REPL, Storage
|
||||
exposed-modules: IndexProject, HackageArchive, Stackage
|
||||
build-depends: base >= 4.7 && < 5
|
||||
, directory
|
||||
, containers
|
||||
@ -32,6 +32,7 @@ library
|
||||
, pureMD5
|
||||
, aeson
|
||||
, data-default
|
||||
, megaparsec
|
||||
, text
|
||||
, mtl
|
||||
, safecopy
|
||||
@ -67,6 +68,8 @@ test-suite index-project-test
|
||||
, index-project
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, megaparsec
|
||||
, text
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
@ -1,14 +1,25 @@
|
||||
module Common(
|
||||
URL,
|
||||
module Common(URL,
|
||||
PackageName,
|
||||
PackageData,
|
||||
SnapshotData(..),
|
||||
UpdateArchiveException(..)
|
||||
) where
|
||||
import Data.Version as DV
|
||||
import Data.Int(Int64)
|
||||
UpdateArchiveException(..),
|
||||
HackageUpdateInfo(..),
|
||||
getArchive,
|
||||
getArchiveClone,
|
||||
getTar,
|
||||
getTarClone,
|
||||
parseIntEnd,
|
||||
parseValEnd) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.List as DL
|
||||
|
||||
import Data.Version as DV
|
||||
import Data.Int(Int64)
|
||||
|
||||
import Data.Default
|
||||
import System.FilePath((</>))
|
||||
|
||||
type URL = String
|
||||
type PackageName = String
|
||||
@ -19,11 +30,59 @@ data SnapshotData = SnapshotData {
|
||||
lengthFile :: Int64
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
-- The exception, that is raised, when there is 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
|
||||
data HackageUpdateInfo = IUH {
|
||||
iuhUpdateDir :: FilePath,
|
||||
iuhSnapshotURL :: URL,
|
||||
iuhArchiveURL :: URL
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Default HackageUpdateInfo where
|
||||
def = defaultIUH
|
||||
|
||||
defaultIUH :: HackageUpdateInfo
|
||||
defaultIUH = IUH {
|
||||
iuhUpdateDir = "hackagefiles",
|
||||
iuhSnapshotURL = "https://hackage.haskell.org/snapshot.json",
|
||||
iuhArchiveURL = "https://hackage.haskell.org/01-index.tar.gz"
|
||||
}
|
||||
|
||||
archive :: FilePath
|
||||
archive = "01-index.tar.gz"
|
||||
|
||||
archiveClone :: FilePath
|
||||
archiveClone = "01-index.tar.gz.orig"
|
||||
|
||||
tar :: FilePath
|
||||
tar = "01-index.tar"
|
||||
|
||||
tarClone :: FilePath
|
||||
tarClone = "01-index.orig.tar"
|
||||
|
||||
getArchive :: HackageUpdateInfo -> FilePath
|
||||
getArchive iuh = iuhUpdateDir iuh </> archive
|
||||
|
||||
getArchiveClone :: HackageUpdateInfo -> FilePath
|
||||
getArchiveClone iuh = iuhUpdateDir iuh </> archiveClone
|
||||
|
||||
getTar :: HackageUpdateInfo -> FilePath
|
||||
getTar iuh = iuhUpdateDir iuh </> tar
|
||||
|
||||
getTarClone :: HackageUpdateInfo -> FilePath
|
||||
getTarClone iuh = iuhUpdateDir iuh </> tarClone
|
||||
|
||||
|
||||
parseIntEnd :: (Num a, Read a) => String -> a
|
||||
parseIntEnd val | not (null l) = read (DL.last l)
|
||||
| otherwise = 0
|
||||
where l = words val
|
||||
|
||||
parseValEnd :: String -> String
|
||||
parseValEnd val | DL.length l > 1 = DL.last l
|
||||
| otherwise = ""
|
||||
where l = words val
|
||||
|
||||
@ -35,7 +35,7 @@ type FileSnapshotData = SnapshotData
|
||||
|
||||
-- Calculates the file size
|
||||
getFileSize :: FilePath -> IO Int64
|
||||
getFileSize path = getFileStatus path >>= return.fileSize >>= \(COff v) -> return v
|
||||
getFileSize path = fileSize <$> getFileStatus path >>= \(COff v) -> return v
|
||||
|
||||
-- Calculates the snapshot of the file of the archive
|
||||
calcFileData :: FilePath -> IO FileSnapshotData
|
||||
@ -51,7 +51,7 @@ calcFileData file = do
|
||||
|
||||
-- Calculates the MD5 hash of the file
|
||||
calcMD5 :: FilePath -> IO MD5Digest
|
||||
calcMD5 file = BL.readFile file >>= return.md5
|
||||
calcMD5 file = md5 <$> BL.readFile file
|
||||
|
||||
-- Deletes the file it it exists.
|
||||
removeIfExists :: FilePath -> IO ()
|
||||
@ -92,10 +92,9 @@ getFileSubstring file from len = do
|
||||
unzipFile :: FilePath -> FilePath -> IO()
|
||||
unzipFile from to = do
|
||||
removeIfExists to
|
||||
fileBody <- (BL.readFile from)
|
||||
fileBody <- BL.readFile from
|
||||
BL.appendFile to (GZip.decompress fileBody)
|
||||
|
||||
|
||||
loadTar :: FilePath -> IO (Tar.Entries Tar.FormatError)
|
||||
loadTar file = do
|
||||
content <- BL.readFile file
|
||||
|
||||
@ -8,8 +8,8 @@ module HackageArchive (
|
||||
HackageName,
|
||||
HackageMap,
|
||||
HackageUpdateMap,
|
||||
HackageUpdate
|
||||
) where
|
||||
HackageUpdate,
|
||||
parsePath) where
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Data.List.Split as SPLT
|
||||
@ -69,7 +69,7 @@ parseCabalFilePath = do
|
||||
guard (name == package)
|
||||
suff <- RP.string ".cabal"
|
||||
RP.eof
|
||||
pure $ (package, version)
|
||||
pure (package, version)
|
||||
where phi l = DC.isLetter l || l == '-'
|
||||
|
||||
updateMapCompare :: (Ord a) => String -> a -> M.Map String a -> M.Map String a
|
||||
@ -87,7 +87,7 @@ buildDifferenceMap oldMap newMap = foldr M.union M.empty [deletedMap, addedMap,
|
||||
addedMap = M.map ((,) Added) $ M.difference newMap oldMap
|
||||
updatedMap' = M.intersection newMap oldMap
|
||||
updatedMap = M.map ((,) Updated) $ M.differenceWith diff updatedMap' oldMap
|
||||
diff newpack oldpack = if (newpack /= oldpack) then Just newpack else Nothing
|
||||
diff newpack oldpack = if newpack /= oldpack then Just newpack else Nothing
|
||||
|
||||
createPackage :: DPD.PackageDescription -> HackagePackage
|
||||
createPackage pd = HP { name = nm, version = ver, author = auth }
|
||||
@ -104,7 +104,7 @@ parsePath path = case RP.readP_to_S parseCabalFilePath path of
|
||||
|
||||
parsePackageDescription :: Tar.EntryContent -> Maybe DPD.PackageDescription
|
||||
parsePackageDescription (Tar.NormalFile content _) =
|
||||
case (DPDP.parsePackageDescription (UTFC.toString content)) of
|
||||
case DPDP.parsePackageDescription (UTFC.toString content) of
|
||||
DPDP.ParseOk _ pd -> Just (DPD.packageDescription pd)
|
||||
DPDP.ParseFailed _ -> Nothing
|
||||
parsePackageDescription _ = Nothing
|
||||
@ -137,7 +137,7 @@ buildHackageMap (Tar.Next entry entries) premap =
|
||||
update path = do
|
||||
(name, version) <- parsePath path
|
||||
preversion <- M.lookup name premap
|
||||
if (preversion == version) then parsePackage entry
|
||||
if preversion == version then parsePackage entry
|
||||
else Nothing
|
||||
buildHackageMap Tar.Done _ = M.empty
|
||||
buildHackageMap (Tar.Fail e) _ = X.throw e
|
||||
|
||||
@ -4,6 +4,13 @@ module HackageUpdate (
|
||||
performArchiveFileUpdate,
|
||||
calcUpdateResultIO) where
|
||||
|
||||
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 Network.HTTP.Client(parseUrlThrow)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Int(Int64)
|
||||
|
||||
@ -11,6 +18,22 @@ import HttpDownload
|
||||
import FileUtils
|
||||
import Common
|
||||
|
||||
type HackageSnapshotData = SnapshotData
|
||||
|
||||
-- This is the data that is extracted from the path to cabal file
|
||||
-- Like, when program parses "safeio/0.0.2.0/safeio.cabal"
|
||||
-- It gets the version 0.0.2.0 and safeio package name. Also checks, xxx and yyy match in
|
||||
-- "xxx/version/yyy.cabal
|
||||
instance FromJSON SnapshotData where
|
||||
parseJSON = withObject "snapshot" $ \o -> do
|
||||
signedO <- o .: "signed"
|
||||
metaO <- signedO .: "meta"
|
||||
tarO <- metaO .: "<repo>/01-index.tar.gz"
|
||||
hashesO <- tarO .: "hashes"
|
||||
md5str <- hashesO .: "md5"
|
||||
len <- tarO .: "length"
|
||||
return (SnapshotData md5str len)
|
||||
|
||||
-- The action, that is needed to perform to correctly update the downloaded
|
||||
-- archive. ArchiveIsOk - everything is fine.
|
||||
-- Update - need to add some information to the end of the file
|
||||
@ -39,6 +62,18 @@ calcUpdateResultIO file json = do
|
||||
return (calcUpdateResult snapshot fileData, snapshot, fileData)
|
||||
|
||||
|
||||
-- The method, that raises an exception, if it was not able to parse the
|
||||
-- snapshot from JSON
|
||||
parseSnapshotJSONThrow :: BL.ByteString -> IO HackageSnapshotData
|
||||
parseSnapshotJSONThrow body = case A.decode body of
|
||||
(Just snapshot) -> return snapshot
|
||||
Nothing -> X.throwIO $ UAE "Could not decode JSON"
|
||||
|
||||
-- Returns the snapshot of archive from the hackage
|
||||
fetchSnapshot :: URL -> IO HackageSnapshotData
|
||||
fetchSnapshot url = parseUrlThrow url >>= fetchResponseData >>= parseSnapshotJSONThrow
|
||||
|
||||
|
||||
-- performs the update, returns True if the the archive was modified
|
||||
performArchiveFileUpdate :: URL -> URL -> FilePath -> IO UpdateResult
|
||||
performArchiveFileUpdate snapshotURL archiveURL archive = do
|
||||
@ -46,13 +81,13 @@ performArchiveFileUpdate snapshotURL archiveURL archive = do
|
||||
(status, snapshot, _) <- calcUpdateResultIO archive snapshotURL
|
||||
|
||||
case status of
|
||||
ArchiveIsOk -> (putStrLn $ "Archive is up to date") >> return ArchiveIsOk
|
||||
ArchiveIsOk -> putStrLn "Archive is up to date" >> return ArchiveIsOk
|
||||
_ -> cutUpdate modifFunctions
|
||||
where
|
||||
performUpdate = updateArchive archive archiveURL
|
||||
modifFunctions = [return (), cutting 50000, cutting 500000, cutting 5000000, removing]
|
||||
cutting val = do
|
||||
putStrLn $ "\tCutting " ++ (show val) ++ " from " ++ archive
|
||||
putStrLn $ "\tCutting " ++ show val ++ " from " ++ archive
|
||||
truncateIfExists archive val
|
||||
removing = do
|
||||
putStrLn $ "\tRemoving " ++ archive
|
||||
@ -65,8 +100,8 @@ performArchiveFileUpdate snapshotURL archiveURL archive = do
|
||||
ArchiveIsOk -> return ArchiveIsOk
|
||||
Corrupted -> cutUpdate mfs
|
||||
Update range -> do
|
||||
putStrLn $ "\tSnapshot from " ++ snapshotURL ++ " " ++ (show snapshot)
|
||||
putStrLn $ "\tUpdate range " ++ (show range)
|
||||
putStrLn $ "\tSnapshot from " ++ snapshotURL ++ " " ++ show snapshot
|
||||
putStrLn $ "\tUpdate range " ++ show range
|
||||
result <- performUpdate snapshot range
|
||||
if result then return status
|
||||
else cutUpdate mfs
|
||||
@ -82,9 +117,9 @@ updateArchive archive archiveURL snapshot range = do
|
||||
|
||||
write2File :: FilePath -> URL -> Range -> IO()
|
||||
write2File archive url range = do
|
||||
putStrLn $ "\tGetting range " ++ (show range) ++ " from " ++ url
|
||||
putStrLn $ "\tGetting range " ++ show range ++ " from " ++ url
|
||||
body <- fetchRangeData url range
|
||||
putStrLn $ "\tGot range " ++ (show (BL.take 50 body))
|
||||
putStrLn $ "\tGot range " ++ show (BL.take 50 body)
|
||||
BL.appendFile archive body
|
||||
putStrLn "Append ok"
|
||||
|
||||
|
||||
@ -1,43 +1,20 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module HttpDownload(HackageSnapshotData,
|
||||
UpdateArchiveException(..),
|
||||
fetchSnapshot,
|
||||
module HttpDownload(
|
||||
fetchResponseData,
|
||||
fetchRangeData,
|
||||
Range,
|
||||
cropRanges
|
||||
) where
|
||||
import Data.Aeson.Types
|
||||
cropRanges) where
|
||||
import Data.Int(Int64)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Parser as AP
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Network.HTTP.Client(Request(..), parseUrlThrow, newManager, responseBody, httpLbs)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import Network.HTTP.Types.Header
|
||||
import qualified Control.Exception as X
|
||||
|
||||
import Common
|
||||
|
||||
type HackageSnapshotData = SnapshotData
|
||||
|
||||
-- This is the data that is extracted from the path to cabal file
|
||||
-- Like, when program parses "safeio/0.0.2.0/safeio.cabal"
|
||||
-- It gets the version 0.0.2.0 and safeio package name. Also checks, xxx and yyy match in
|
||||
-- "xxx/version/yyy.cabal
|
||||
instance FromJSON SnapshotData where
|
||||
parseJSON = withObject "snapshot" $ \o -> do
|
||||
signedO <- o .: "signed"
|
||||
metaO <- signedO .: "meta"
|
||||
tarO <- metaO .: "<repo>/01-index.tar.gz"
|
||||
hashesO <- tarO .: "hashes"
|
||||
md5str <- hashesO .: "md5"
|
||||
len <- tarO .: "length"
|
||||
return (SnapshotData md5str len)
|
||||
|
||||
-- The range, from which to download
|
||||
type Range = (Int64, Int64)
|
||||
|
||||
@ -62,21 +39,9 @@ makeRangeRequest (from, to) = makeRange
|
||||
|
||||
-- Returns the data from response, returned to the request
|
||||
fetchResponseData :: Request -> IO BL.ByteString
|
||||
fetchResponseData req = newManager tlsManagerSettings >>= httpLbs req >>= return.responseBody
|
||||
fetchResponseData req = responseBody <$> (newManager tlsManagerSettings >>= httpLbs req)
|
||||
|
||||
-- Returns the bytes from the range request
|
||||
fetchRangeData :: URL -> Range -> IO BL.ByteString
|
||||
fetchRangeData url range = createRangeRequest url range >>= fetchResponseData
|
||||
|
||||
-- The method, that raises an exception, if it was not able to parse the
|
||||
-- snapshot from JSON
|
||||
parseSnapshotJSONThrow :: BL.ByteString -> IO HackageSnapshotData
|
||||
parseSnapshotJSONThrow body = case A.decode body of
|
||||
(Just snapshot) -> return snapshot
|
||||
Nothing -> X.throwIO $ UAE "Could not decode JSON"
|
||||
|
||||
-- Returns the snapshot of archive from the hackage
|
||||
fetchSnapshot :: URL -> IO HackageSnapshotData
|
||||
fetchSnapshot url = parseUrlThrow url >>= fetchResponseData >>= parseSnapshotJSONThrow
|
||||
|
||||
|
||||
|
||||
188
REPL/src/REPL.hs
188
REPL/src/REPL.hs
@ -10,16 +10,15 @@ module REPL ( processCycle,
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Char as DC
|
||||
import qualified Data.List as DL
|
||||
import qualified Control.Exception as X
|
||||
import Control.Monad(forever)
|
||||
import Control.Monad(forever, void)
|
||||
import System.IO (stdout, hFlush)
|
||||
import Data.Default
|
||||
|
||||
import Data.Int(Int64)
|
||||
import System.Exit(exitSuccess)
|
||||
import System.Directory(copyFile)
|
||||
import System.FilePath((</>))
|
||||
import Data.List(isPrefixOf)
|
||||
|
||||
import Common
|
||||
import HackageArchive
|
||||
@ -28,71 +27,18 @@ import FileUtils
|
||||
import HttpDownload
|
||||
import Storage
|
||||
|
||||
-- the constructor short name is really awkward in russian
|
||||
data HackageUpdateInfo = IUH {
|
||||
iuhUpdateDir :: FilePath,
|
||||
iuhSnapshotURL :: URL,
|
||||
iuhArchiveURL :: URL
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Default HackageUpdateInfo where
|
||||
def = defaultIUH
|
||||
|
||||
defaultIUH :: HackageUpdateInfo
|
||||
defaultIUH = IUH {
|
||||
iuhUpdateDir = "hackagefiles",
|
||||
iuhSnapshotURL = "https://hackage.haskell.org/snapshot.json",
|
||||
iuhArchiveURL = "https://hackage.haskell.org/01-index.tar.gz"
|
||||
}
|
||||
|
||||
getArchive :: HackageUpdateInfo -> FilePath
|
||||
getArchive iuh = (iuhUpdateDir iuh) </> archive
|
||||
|
||||
getArchiveClone :: HackageUpdateInfo -> FilePath
|
||||
getArchiveClone iuh = (iuhUpdateDir iuh) </> archiveClone
|
||||
|
||||
|
||||
getTar :: HackageUpdateInfo -> FilePath
|
||||
getTar iuh = (iuhUpdateDir iuh) </> tar
|
||||
|
||||
getTarClone :: HackageUpdateInfo -> FilePath
|
||||
getTarClone iuh = (iuhUpdateDir iuh) </> tarClone
|
||||
|
||||
archive :: FilePath
|
||||
archive = "01-index.tar.gz"
|
||||
|
||||
archiveClone :: FilePath
|
||||
archiveClone = "01-index.tar.gz.orig"
|
||||
|
||||
tar :: FilePath
|
||||
tar = "01-index.tar"
|
||||
|
||||
tarClone :: FilePath
|
||||
tarClone = "01-index.orig.tar"
|
||||
|
||||
parseIntEnd :: (Num a, Read a) => String -> a
|
||||
parseIntEnd val | DL.length l > 0 = read (DL.last l)
|
||||
| otherwise = 0
|
||||
where l = words val
|
||||
|
||||
parseValEnd :: String -> String
|
||||
parseValEnd val | DL.length l > 1 = DL.last l
|
||||
| otherwise = ""
|
||||
where l = words val
|
||||
|
||||
processCycle :: HackageUpdateInfo -> IO ()
|
||||
processCycle iuh = forever $ do
|
||||
putStr "Input command: "
|
||||
hFlush stdout
|
||||
command <- getLine
|
||||
hFlush stdout
|
||||
(processCommand command) `X.catch` eh `X.catch` eh2 `X.catch` eh3
|
||||
processCommand command `X.catch` eh `X.catch` eh2 `X.catch` eh3
|
||||
where
|
||||
processCommand = buildCommand iuh
|
||||
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)
|
||||
|
||||
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
|
||||
@ -124,11 +70,11 @@ buildCommand iuh = processCommand
|
||||
| chk "tarparse" = showMap trFile 50 -- loads the tar information in the memory
|
||||
|
||||
| chk "compare" = showArchiveCompare arch archC
|
||||
| chk "update" = performArchiveFileUpdate snapURL archURL arch >> return ()
|
||||
| chk "update" = void $ performArchiveFileUpdate snapURL archURL arch
|
||||
|
||||
| chk "acidcompare" = printAcidCompare ud trFile
|
||||
| chk "acidupdate" = acidUpdate ud trFile
|
||||
| chk "acidquery" = printAcidQuery ud (parseValEnd command)
|
||||
| chk "acidquery" = showAcidQuery ud (parseValEnd command)
|
||||
|
||||
| chk "tarcmp" = showDiffMap trFile trFileC
|
||||
| chk "exit" = exitREPL
|
||||
@ -137,7 +83,7 @@ buildCommand iuh = processCommand
|
||||
| otherwise = showHelp iuh
|
||||
|
||||
where pc = map DC.toLower command
|
||||
chk val = DL.isPrefixOf val pc
|
||||
chk val = val `isPrefixOf` pc
|
||||
|
||||
arch = getArchive iuh
|
||||
archC = getArchiveClone iuh
|
||||
@ -147,22 +93,58 @@ buildCommand iuh = processCommand
|
||||
trFileC = getTarClone iuh
|
||||
ud = iuhUpdateDir iuh
|
||||
|
||||
showHelp :: HackageUpdateInfo -> IO()
|
||||
showHelp iuh = 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 $ "acidupdate - updates the acid state with " ++ trFile
|
||||
putStrLn "acidquery name - queries the acid with package"
|
||||
putStrLn "exit - exits this repl"
|
||||
|
||||
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)
|
||||
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)
|
||||
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 ()
|
||||
@ -178,15 +160,15 @@ copyArchive archive1 archive2 = do
|
||||
copyFile archive1 archive2
|
||||
putStrLn $ "Copied the " ++ archive1 ++ " to " ++ archive2
|
||||
|
||||
showMap :: FilePath -> Int -> IO()
|
||||
showMap :: FilePath -> Int -> IO ()
|
||||
showMap path count = do
|
||||
putStrLn $ "Displaying " ++ (show count) ++ " entries for " ++ path
|
||||
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 :: FilePath -> Int -> IO ()
|
||||
showPreMap path count = do
|
||||
putStrLn $ "Pre displaying " ++ (show count) ++ " entries for " ++ path
|
||||
putStrLn $ "Pre displaying " ++ show count ++ " entries for " ++ path
|
||||
tar <- loadTar path
|
||||
mapM_ print $ take count $ {-filter ((elem '-').fst) $-} M.toList $ buildPreHackageMap tar
|
||||
|
||||
@ -201,46 +183,21 @@ showDiffMap newTarFile oldTarFile = do
|
||||
let diffMap = buildDifferenceMap oldMap newMap
|
||||
mapM_ (print.snd) $ M.toList diffMap
|
||||
|
||||
showHelp :: HackageUpdateInfo -> IO()
|
||||
showHelp iuh = 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 $ "acidupdate - updates the acid state with " ++ trFile
|
||||
putStrLn $ "acidquery name - queries the acid with package"
|
||||
putStrLn "exit - exits this repl"
|
||||
|
||||
where
|
||||
arch = getArchive iuh
|
||||
archC = getArchiveClone iuh
|
||||
archURL = iuhArchiveURL iuh
|
||||
snapURL = iuhSnapshotURL iuh
|
||||
trFile = getTar iuh
|
||||
trFileC = getTarClone iuh
|
||||
|
||||
showArchiveCompare :: FilePath -> FilePath -> IO()
|
||||
showArchiveCompare archive1 archive2= do
|
||||
val <- compareFiles archive1 archive2
|
||||
putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ (show val)
|
||||
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"
|
||||
|
||||
|
||||
exitREPL :: IO()
|
||||
exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess
|
||||
@ -250,7 +207,7 @@ exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess
|
||||
cutFile :: FilePath -> Int64 -> IO()
|
||||
cutFile path size = do
|
||||
truncateIfExists path size
|
||||
putStrLn $ "Cut " ++ (show size) ++ " bytes from " ++ path
|
||||
putStrLn $ "Cut " ++ show size ++ " bytes from " ++ path
|
||||
|
||||
unzipArchive :: FilePath -> FilePath -> IO()
|
||||
unzipArchive archive tar = do
|
||||
@ -263,7 +220,6 @@ removeArchiveFiles archive tar = do
|
||||
removeIfExists archive
|
||||
removeIfExists tar
|
||||
|
||||
|
||||
printAcidCompare :: FilePath -> FilePath -> IO()
|
||||
printAcidCompare updateDir tarFile = do
|
||||
newTar <- loadTar tarFile
|
||||
@ -276,18 +232,8 @@ acidUpdate updateDir tarFile = do
|
||||
let newMap = buildHackageMap newTar (buildPreHackageMap newTar)
|
||||
updateAcidMap updateDir newMap
|
||||
|
||||
printAcidQuery :: FilePath -> HackageName -> IO()
|
||||
printAcidQuery 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"
|
||||
|
||||
updateArchive :: HackageUpdateInfo -> IO()
|
||||
updateArchive iuh = performArchiveFileUpdate snapURL archURL arch >> return ()
|
||||
updateArchive iuh = void (performArchiveFileUpdate snapURL archURL arch)
|
||||
where
|
||||
arch = getArchive iuh
|
||||
archURL = iuhArchiveURL iuh
|
||||
|
||||
@ -1,20 +1,78 @@
|
||||
module Stackage() where
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Stackage(
|
||||
parseLTSLine,
|
||||
parsePackageLine) where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Text
|
||||
import qualified Text.Megaparsec.Lexer as L
|
||||
|
||||
import qualified Data.Version as DV
|
||||
import qualified Data.Map as M
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
import Control.Monad (void)
|
||||
import Control.Applicative(empty)
|
||||
|
||||
import Common
|
||||
|
||||
type ConstraintMap = M.Map PackageName PackageData
|
||||
type ShortSnapshotName = String
|
||||
type LongSnapshotName = String
|
||||
type StackageSnapshot = (ShortSnapshotName, LongSnapshotName)
|
||||
|
||||
-- the minor and major versions for stackage
|
||||
type StackageLTS = (Int, Int)
|
||||
shortName :: StackageSnapshot -> String
|
||||
shortName = fst
|
||||
|
||||
data LTS = LTS {
|
||||
name :: String,
|
||||
url :: URL,
|
||||
constraints :: ConstraintMap
|
||||
}
|
||||
longName :: StackageSnapshot -> String
|
||||
longName = snd
|
||||
|
||||
type StackageLTS = (LongSnapshotName, [PackageData])
|
||||
|
||||
parseStackageLTS :: Parser StackageLTS
|
||||
parseStackageLTS = do
|
||||
many (try (manyTill anyChar eol >> notFollowedBy parseLTSLine))
|
||||
ltsName <- parseLTSLine
|
||||
--packages =
|
||||
pure (ltsName, [])
|
||||
|
||||
parseLTSLine :: Parser LongSnapshotName
|
||||
parseLTSLine = do
|
||||
-- destroy everything
|
||||
manyTill anyChar (string "http://www.stackage.org/snapshot/")
|
||||
name <- some (letterChar <|> digitChar <|> char '.' <|> char '-')
|
||||
space
|
||||
void eol <|> eof
|
||||
pure name
|
||||
|
||||
parsePackageLine :: Parser PackageData
|
||||
parsePackageLine = do
|
||||
packageData <- try parsePackageConst <|> parsePackageEmpty
|
||||
space
|
||||
manyTill anyChar (void eol <|> eof)
|
||||
pure packageData
|
||||
|
||||
parsePackageConst :: Parser PackageData
|
||||
parsePackageConst = do
|
||||
manyTill anyChar (char ':') -- chop the 'constraints:' in the beginning
|
||||
parsePackageEmpty
|
||||
|
||||
parsePackageEmpty :: Parser PackageData
|
||||
parsePackageEmpty = do
|
||||
space
|
||||
parsePackageData
|
||||
|
||||
parsePackageData :: Parser PackageData
|
||||
parsePackageData = do
|
||||
name <- some (letterChar <|> digitChar <|> char '-')
|
||||
space
|
||||
string "=="
|
||||
space
|
||||
version <- parseVersion
|
||||
many (char ',')
|
||||
pure (name, version)
|
||||
|
||||
parseVersion :: Parser DV.Version
|
||||
parseVersion = do
|
||||
numbers <- sepBy1 L.integer (char '.')
|
||||
pure $ DV.Version (map fromIntegral numbers) []
|
||||
|
||||
@ -20,8 +20,7 @@ import qualified Control.Monad.State as State
|
||||
import HackageArchive
|
||||
import qualified Data.Version as DV
|
||||
|
||||
data KeyValue = KeyValue !HackageMap
|
||||
deriving (Typeable)
|
||||
newtype KeyValue = KeyValue HackageMap deriving (Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''DV.Version)
|
||||
$(deriveSafeCopy 0 'base ''HackagePackage)
|
||||
@ -53,7 +52,7 @@ printAcidDiffMap path newMap = do
|
||||
acid <- openLocalStateFrom path (KeyValue M.empty)
|
||||
do
|
||||
diffMap <- query acid (CompareMap newMap)
|
||||
putStrLn $ "Printing difference map with acid-state"
|
||||
putStrLn "Printing difference map with acid-state"
|
||||
mapM_ (print.snd) $ M.toList diffMap
|
||||
closeAcidState acid
|
||||
|
||||
@ -61,7 +60,7 @@ updateAcidMap :: FilePath -> HackageMap -> IO ()
|
||||
updateAcidMap path newMap = do
|
||||
acid <- openLocalStateFrom path (KeyValue M.empty)
|
||||
do
|
||||
putStrLn $ "Updating the acid map"
|
||||
putStrLn "Updating the acid map"
|
||||
update acid (UpdateMap newMap)
|
||||
closeAcidState acid
|
||||
|
||||
|
||||
@ -1,39 +1,80 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import Data.Ord
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Text
|
||||
import Data.Either (isRight, either)
|
||||
import qualified Data.Text as T
|
||||
import Data.Monoid ((<>))
|
||||
import HackageArchive
|
||||
import Stackage
|
||||
|
||||
import TarUtil as TU
|
||||
import qualified Data.Text.IO as TIO
|
||||
|
||||
parseTests = testGroup "Different parsing tests"
|
||||
testWorkingDir :: String
|
||||
testWorkingDir = "testworkdir"
|
||||
|
||||
parseTests = testGroup "Hackage archive parsing tests"
|
||||
[
|
||||
-- testCase "'-' chat in package name parsing" $
|
||||
-- (fst <$> parsePath "file-collection/0.1.1.9/file-collection.cabal")
|
||||
-- `compare` (Just "file-collection") @?= EQ,
|
||||
testPath "filecollection/0.1.1.9/filecollection.cabal" "filecollection" True
|
||||
, testPath "filecollection/0.1.1.9/filecollection.cabal" "filecollectionz" False
|
||||
, testPath "file-collection/0.1.1.9/file-collection.cabal" "file-collection" True
|
||||
, testPath "file-collection/0.1.1.9/file-collection.cabal" "filecollection" False
|
||||
]
|
||||
|
||||
testCase "Package name parsing" $
|
||||
(fst <$> parsePath "filecollection/0.1.1.9/filecollection.cabal") == (Just "filecollection") @?= True
|
||||
|
||||
, testCase "Package name parsing" $
|
||||
(fst <$> parsePath "filecollection/0.1.1.9/filecollection.cabal") == (Just "filecollectionz") @?= False
|
||||
|
||||
, testCase "Package name parsing" $
|
||||
(fst <$> parsePath "file-collection/0.1.1.9/file-collection.cabal") == (Just "file-collection") @?= True
|
||||
testPath :: T.Text -> T.Text -> Bool -> TestTree
|
||||
testPath text val match = testCase (T.unpack ("Parsing " <> expect match <> " \'" <> text <> "\'")) $
|
||||
assertBool "Failed" $ ((fst <$> parsePath (T.unpack text)) == Just (T.unpack val)) == match
|
||||
|
||||
, testCase "Package name parsing" $
|
||||
(fst <$> parsePath "file-collection/0.1.1.9/file-collection.cabal") == (Just "filecollection") @?= False
|
||||
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
|
||||
, testParse parsePackageLine "adjunctions ==4.3," True
|
||||
|
||||
, testParse parseLTSLine "-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.10" True
|
||||
, testParse parseLTSLine "-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.$10" False
|
||||
, testParse parseLTSLine "-- Please place this file next to your .cabal file as cabal.config" False
|
||||
, testParse parseLTSLine "-- To only use tested packages, uncomment the following line:" False
|
||||
, testParse parseLTSLine "-- remote-repo: stackage-lts-2.10:http://www.stackage.org/lts-2.10" False
|
||||
, testParse parseLTSLine "constraints: abstract-deque ==0.3," False
|
||||
, testParse parseLTSLine "abstract-par ==0.3.3," False
|
||||
, testParse parseLTSLine "zlib-lens ==0.1.2" False
|
||||
, testParse parseLTSLine "-- Stackage snapshot from: http://www.stackage.org/snapshot/nightly-2017-06-10" True
|
||||
]
|
||||
{-
|
||||
[ testCase "List comparison (different length)" $
|
||||
[1, 2, 3] `compare` [1,2] @?= GT
|
||||
|
||||
-- the following test does not hold
|
||||
, testCase "List comparison (same length)" $
|
||||
[1, 2, 3] `compare` [1,2,2] @?= LT
|
||||
parseCabalConfig = (testWorkDir </> "sometestfile.cnf") testGroup "Cabal config parser tests"
|
||||
[
|
||||
testFileParse parseStackageLTS
|
||||
]
|
||||
-}
|
||||
|
||||
expect :: Bool -> T.Text
|
||||
expect True = "expect success"
|
||||
expect False = "expect fail"
|
||||
|
||||
testParse :: Parser a -> T.Text -> Bool -> TestTree
|
||||
testParse p text match = testCase (T.unpack ("Parsing " <> expect match <> " \'" <> text <> "\'")) $
|
||||
assertBool "Failed" (isRight (runParser p "" text) == match)
|
||||
|
||||
testFileParse :: FilePath -> Parser a -> (T.Text -> b) -> (b -> a -> Bool) -> TestTree
|
||||
testFileParse file p textFunc matchFunc =
|
||||
testCase ("Testing file: " ++ file) $ do
|
||||
fileText <- TIO.readFile file -- got the file
|
||||
let textVal = textFunc fileText
|
||||
let eVal = matchFunc textVal <$> runParser p "" fileText
|
||||
assertBool "Failed" (either (const False) id eVal)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "REPL tests" [parseTests]
|
||||
tests = testGroup "REPL tests" [parseStackageTests, parseTests]
|
||||
|
||||
|
||||
main = defaultMain parseTests
|
||||
main = defaultMain tests
|
||||
|
||||
Loading…
Reference in New Issue
Block a user