Make the smart update, that cuts the end on an archive in case the md5 did not match

REPL/app/Main.hs

@@ -13,72 +13,7 @@ import System.Directory(copyFile)
 import System.IO (stdout, hFlush)
 import qualified Data.Map.Strict as Map
 
-import ArchiveUpdate
-import TarUtil 
 import REPL
-{-
-updateHackage :: IO()
-updateHackage = do
-  val <- performSmartUpdate archiveFile snapshotURL archiveURL
-  putStrLn $ "Updated " ++ show val
-
--- Compares the hackage archive file with the original file
-compareArchive :: FilePath -> FilePath -> IO()
-compareArchive archive1 archive2= do
-  val <- compareFiles archive1 archive2
-  putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ (show val)
-
--- Parses the integer value at the end of the string
--- Used to parse commands like "cut 42"
-parseIntEnd :: (Num a, Read a) => String -> a
-parseIntEnd val | DL.length l > 0 = read (DL.last l)
-                | otherwise = 0
-  where l = words val
-
-processCommand :: String -> IO()
-processCommand command
-  | chk "check" = showUpdateData archiveFile snapshotURL -- checks the current gzip archive and understands what to download
-  | chk "checkclone" = showUpdateData archiveCloneFile snapshotURL -- checks the current gzip archive and understands what to download
-
-  | chk "file" = showFileSnapshot archiveFile  -- shows the snapshot of hackage file
-  | chk "fileclone" = showFileSnapshot archiveCloneFile
-  | chk "copyorig" = copyArchive archiveFile archiveCloneFile -- copies the current archive to the orig place
- 
-  | chk "cut" = cutFile archiveFile (parseIntEnd command) -- cuts the end of the gzip file for checking purposes
-  | chk "cutclone" = cutFile archiveCloneFile (parseIntEnd command) 
-
-  | chk "unzip" = unzipArchive archiveFile tarArchive  -- unzips the downloaded gzip archive
-  | chk "unzipclone" = unzipArchive archiveCloneFile tarArchiveClone -- unzips the downloaded gzip archive
-
-  | chk "tarparse" = showMap tarArchive 50  -- loads the tar information in the memory
-  | chk "tarparseclone" = showMap tarArchiveClone 50 -- loads the tar clone information in the memory
-  
-  | chk "tarshow" = showTarContents tarArchive
-  | chk "tarshowclone" = showTarContents tarArchiveClone
-
-  | chk "compare" = showArchiveCompare archiveFile archiveCloneFile 
-  | chk "update" = updateHackage -- updates the current gzip archive
-  
-  | chk "tarcmp" = showDiffMap tarArchive tarArchiveClone
-  | chk "exit" = exitREPL
-
-  | chk "help" = showHelp
-  | otherwise = showHelp
-  where pc = map DC.toLower command
-        chk val = DL.isPrefixOf val pc
-
-processCycle :: IO ()
-processCycle = forever $ do
-  putStr "Input command: "
-  hFlush stdout
-  command <- getLine
-  hFlush stdout
-  (processCommand command) `X.catch` eh `X.catch` eh2 `X.catch` eh3
-  where 
-    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)
--}
 
 defaultPBI :: ProcessBuilderInfo 
 defaultPBI = PBI {

REPL/index-project.cabal

@@ -15,7 +15,7 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     ArchiveUpdate, TarUtil, REPL
+  exposed-modules:     ArchiveUpdate, TarUtil, REPL, Storage
   build-depends:       base >= 4.7 && < 5
                      , directory
                      , containers
@@ -31,11 +31,14 @@ library
                      , pureMD5
                      , aeson
                      , text
+                     , mtl
+                     , safecopy
                      , cereal
                      , unix
                      , exceptions
                      , transformers
                      , zlib
+                     , acid-state
 
   default-language:    Haskell2010
 

REPL/src/ArchiveUpdate.hs

@@ -7,12 +7,12 @@ module ArchiveUpdate (
   FileSnapshotData,
   UpdateArchiveException,
   performArchiveFileUpdate,
-  performArchiveCutUpdate,
   getFileSubstring,
   calcFileData, 
   calcUpdateResult2,
   truncateIfExists,
   unzipFile,
+  removeIfExists,
   compareFiles) where
 
 import Network.HTTP.Client(Request(..), parseUrlThrow, newManager, responseBody, httpLbs)
@@ -136,7 +136,7 @@ calcFileData file = do
 -- archive. ArchiveIsOk - everything is fine.
 -- Update - need to add some information to the end of the file
 -- Reload - need to redownload the whole archive completely
-data UpdateRange = ArchiveIsOk | Reload Range | Update Range deriving (Eq, Show)
+data UpdateRange = ArchiveIsOk | Corrupted | Update Range deriving (Eq, Show)
 
 
 -- The maximum range to download in one request from the hackage
@@ -148,7 +148,7 @@ calcUpdateResult :: HackageSnapshotData -> FileSnapshotData -> UpdateRange
 calcUpdateResult hackage file 
   | hackage == file = ArchiveIsOk -- both are equal
   | lenH > lenF = Update (lenF, lenH - 1) -- need to append a bit
-  | otherwise = Reload (0, lenH - 1) -- delete old file and redownload it
+  | otherwise = Corrupted -- delete old file and redownload it
   where lenH = lengthFile hackage
         lenF = lengthFile file
 
@@ -195,6 +195,7 @@ getFileSubstring :: FilePath -> Int64 -> Int64 -> IO BL.ByteString
 getFileSubstring file from len  = do
   c <- BL.readFile file
   return $ BL.take len $ BL.drop from c
+
 -- unzips the file to the other file
 unzipFile :: FilePath -> FilePath -> IO()
 unzipFile from to = do
@@ -202,56 +203,44 @@ unzipFile from to = do
   fileBody <- (BL.readFile from)
   BL.appendFile to (GZip.decompress fileBody) 
 
-{-
--- The description of the file, that is used to compare archive on the harddisk
--- with the archive in the hackage. It uses length and md5 hash from the pureMD5
--- library
--- Updates the archive with zip stuff
-performSmartUpdate :: FilePath -> URL -> URL -> IO Bool
-performSmartUpdate file json archive = do 
-  (range, snapshot, _) <- calcUpdateResult2 file json
-  case range of
-    ArchiveIsOk -> do
-      putStrLn $ "Archive is up to date"
-      return False
-    (Update range) -> do
-      putStrLn $ "Updating the archive"
-      update range snapshot
-      return True
-    (Reload range) -> do
-      putStrLn $ "Reloading the archive"
-      removeIfExists file
-      update range snapshot
-      return True
-  where 
-    ranges = cropRanges maxRange
-    write2File range = do
-      body <- fetchRangeData archive range
-      print "Start of range: "
-      print $ BL.take 100 body
-      BL.appendFile file body
-      putStrLn $ "\tAppended chunk " ++ (show range)
-    update range snapshot = do
-      mapM_ write2File (ranges range)
-      newFileData <- calcFileData file
-      when (newFileData /= snapshot) $ X.throwIO $ UAE $ "Updated archive corrupted"
--}
 
 -- performs the update, returns True if the the archive was modified
-performArchiveFileUpdate :: URL -> URL -> FilePath -> IO Bool
+
+
+
+performArchiveFileUpdate :: URL -> URL -> FilePath -> IO UpdateRange
 performArchiveFileUpdate snapshotURL archiveURL archive = do
-  (range, snapshot, _) <- calcUpdateResult2 archive snapshotURL
-  putStrLn "Updating"
-  putStrLn $ "Snapshot from " ++ snapshotURL ++ " " ++ (show snapshot)
-  putStrLn $ "Update range " ++ (show range)
-  case range of 
-    ArchiveIsOk -> (putStrLn $ "Archive is up to date") >> return False
-    Update range -> do 
-      putStrLn $ "Updating " ++ archive ++ " from " ++ archiveURL
-      result <- updateArchive archive archiveURL snapshot range
-      putStrLn $ if result then "Update successfull" else "MD5 does not match"
-      return True
-    Reload range -> undefined
+  putStrLn $ "Updating " ++ archive ++ " from " ++ archiveURL
+  (status, snapshot, _) <- calcUpdateResult2 archive snapshotURL
+
+  case status of 
+    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
+      truncateIfExists archive val
+    removing = do
+      putStrLn $ "\tRemoving " ++ archive
+      removeIfExists archive
+
+    cutUpdate (mf : mfs) = do
+      mf
+      (status, snapshot, _) <- calcUpdateResult2 archive snapshotURL
+      case status of 
+        ArchiveIsOk -> return ArchiveIsOk
+        Corrupted -> cutUpdate mfs 
+        Update range -> do
+          putStrLn $ "\tSnapshot from " ++ snapshotURL ++ " " ++ (show snapshot)
+          putStrLn $ "\tUpdate range " ++ (show range)
+          result <- performUpdate snapshot range
+          if result then return status
+                    else cutUpdate mfs
+    cutUpdate [] = do
+      putStrLn "Failed to update"
+      return Corrupted
 
 updateArchive :: FilePath -> URL -> HackageSnapshotData -> Range -> IO Bool
 updateArchive archive archiveURL snapshot range = do
@@ -267,7 +256,7 @@ write2File archive url range = do
   BL.appendFile archive body
   putStrLn "Append ok"
 
-
+{-
 performArchiveCutUpdateF :: (FilePath -> IO Bool) -> FilePath -> Int64 -> IO Bool
 performArchiveCutUpdateF updateFunc archive cutSize = do
   putStrLn $ "Cutting " ++ (show cutSize) ++ " from " ++ archive ++ " before update"
@@ -276,4 +265,25 @@ performArchiveCutUpdateF updateFunc archive cutSize = do
 
 performArchiveCutUpdate :: URL -> URL -> FilePath -> Int64 -> IO Bool
 performArchiveCutUpdate snapshotURL archiveURL = performArchiveCutUpdateF (performArchiveFileUpdate snapshotURL archiveURL)
+-}
 
+  
+  {-
+  case range of 
+    ArchiveIsOk -> (putStrLn $ "Archive is up to date") >> return ArchiveIsOk
+    Update range -> do 
+      putStrLn $ "Updating " ++ archive ++ " from " ++ archiveURL
+      result <- updateArchive archive archiveURL snapshot range
+      putStrLn $ if result then "Update successfull" else "MD5 does not match"
+      return ArchiveIsOk
+   -}   
+    {-
+    Corrupted -> do
+      putStrLn $ "Reloading " ++ archive ++ " from " ++ archiveURL
+      removeIfExists archive
+      result <- updateArchive archive archiveURL snapshot range
+      putStrLn $ if result then "Update successfull" else "MD5 does not match"
+      return True
+    -}
+    
+ 

REPL/src/REPL.hs

@@ -81,8 +81,8 @@ buildCommand pbi = processCommand
       | chk "unzipclone" = unzipArchive (archiveClone pbi) (tarClone pbi) -- unzips the downloaded gzip archive
       | chk "unzip" = unzipArchive (archive pbi) (tar pbi)  -- unzips the downloaded gzip archive
 
-      | chk "cleanclone" = undefined
-      | chk "clean" = undefined
+      | chk "cleanclone" = removeArchiveFiles (archiveClone pbi) (tarClone pbi)
+      | chk "clean" = removeArchiveFiles (archive pbi) (tar pbi)
 
       | chk "tarparsepreclone" = showPreMap (tarClone pbi) 50 -- loads the tar clone information in the memory
       | chk "tarparsepre" = showPreMap (tar pbi) 50  -- loads the tar information in the memory
@@ -91,10 +91,11 @@ buildCommand pbi = processCommand
       | chk "tarparse" = showMap (tar pbi) 50  -- loads the tar information in the memory
 
       | chk "compare" = showArchiveCompare (archive pbi) (archiveClone pbi) 
-
-      | chk "updatecut" = performArchiveCutUpdate (snapshotURL pbi) (archiveURL pbi) 
-                          (archive pbi) (parseIntEnd command) >> return ()
       | chk "update" = performArchiveFileUpdate (snapshotURL pbi) (archiveURL pbi) (archive pbi) >> return ()
+
+--      | chk "acidupdate" = undefined
+--      | chk "acidquery" = undefined
+
       -- | chk "updatesmart" = undefined
 
       | chk "tarcmp" = showDiffMap (tar pbi) (tarClone pbi)
@@ -182,8 +183,8 @@ showHelp pbi = do
   putStrLn $ "tarparsepreclone - same for " ++ (tarClone pbi)
   putStrLn $ "tarcmp - compares the entries of " ++ (tar pbi) ++ " and " ++ (tarClone pbi)
   putStrLn $ "update - updates the current " ++ arch ++ " from " ++ (archiveURL pbi)
-  putStrLn $ "updatecut size - cuts the size from " ++ arch ++ " and then updates"
   putStrLn "exit - exits this repl"
+
   where 
     arch = archive pbi
     archC = archiveClone pbi 
@@ -193,8 +194,6 @@ showArchiveCompare archive1 archive2= do
   val <- compareFiles archive1 archive2
   putStrLn $ "Compare result " ++ archive1 ++ " " ++ archive2 ++ " " ++ (show val)
 
-
-
 exitREPL :: IO()
 exitREPL = putStrLn "Finished working with hackage REPL" >> exitSuccess
 
@@ -210,4 +209,24 @@ unzipArchive archive tar = do
   putStrLn $ "Unzipping " ++ archive ++ " to " ++ tar
   unzipFile archive tar
 
+removeArchiveFiles :: FilePath -> FilePath -> IO()
+removeArchiveFiles archive tar = do
+  putStrLn $ "Removing archive files " ++ archive ++ " " ++ tar
+  removeIfExists archive
+  removeIfExists tar
+
+-- make update of acidic map of the packages
+{-
+updateAcidicMap :: URL -> URL -> FilePath -> IO()
+updateAcidicMap snapU archU arch cutValue = 
+  do  acid <- openLocalState (KeyValue Map.empty)
+      -- update the archive
+      status <- performArchiveCutUpdate snapU archU arch cutValue
+
+      closeAcidState acid
+-}
+
+--rebuildIndex :: URL -> URL -> FilePath -> IO ()
+--rebuildIndex
+
 

REPL/src/Storage.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell    #-}
+
+-- This is modified example from AcidState
+module Storage (
+                insertKey,
+                updateMap,
+                lookupKey,
+                compareMap) where
+
+import Data.Typeable
+import Data.Acid
+import Data.Acid.Advanced
+import Data.SafeCopy
+import Control.Monad.Reader
+
+import qualified Data.Map as M
+import qualified Control.Monad.State  as State
+
+import TarUtil
+import qualified Data.Version as DV
+
+data KeyValue = KeyValue !HackageMap
+    deriving (Typeable)
+type Key = String
+type Value = HackagePackage
+
+
+$(deriveSafeCopy 0 'base ''DV.Version)
+$(deriveSafeCopy 0 'base ''HackagePackage)
+$(deriveSafeCopy 0 'base ''KeyValue)
+
+insertKey :: Key -> Value -> Update KeyValue ()
+insertKey key value = do 
+  KeyValue hackageMap <- State.get
+  State.put (KeyValue (M.insert key value hackageMap))
+
+updateMap :: HackageMap -> Update KeyValue ()
+updateMap newMap = State.put (KeyValue newMap)
+
+lookupKey :: Key -> Query KeyValue (Maybe Value)
+lookupKey key = do
+  KeyValue m <- ask
+  return (M.lookup key m)
+
+compareMap :: HackageMap -> Query KeyValue HackageUpdateMap
+compareMap newMap = do
+  KeyValue oldMap <- ask
+  return (buildDifferenceMap oldMap newMap)
+
+$(makeAcidic ''KeyValue ['insertKey, 'lookupKey])
+
+
+{-
+main :: IO ()
+main = do acid <- openLocalState (KeyValue Map.empty)
+          updated <- performArchiveCutUpdate snapU archU arch cutValue
+
+          -- load the map from acid
+          -- update the map from acid
+          closeAcidState acid
+       where
+        pbi = defaultPBI
+        archU = (archiveURL pbi)
+        snapU = (snapshotURL pbi)
+        arch = (archive pbi)
+        cutValue = 100000
+-}
+          {-
+          case args of
+            [key]
+              -> do mbKey <- query acid (LookupKey key)
+                    case mbKey of
+                      Nothing    -> putStrLn $ key ++ " has no associated value."
+                      Just value -> putStrLn $ key ++ " = " ++ value
+            [key,val]
+              -> do update acid (InsertKey key val)
+                    putStrLn "Done."
+            _ -> do putStrLn "Usage:"
+                    putStrLn "  key               Lookup the value of 'key'."
+                    putStrLn "  key value         Set the value of 'key' to 'value'."
+          closeAcidState acid
+          -}
+

REPL/src/TarUtil.hs

@@ -5,7 +5,10 @@ module TarUtil (
                 buildHackageMap,
                 buildPreHackageMap,
                 loadTar,
-                parsePath
+                parsePath,
+                HackagePackage (..),
+                HackageMap,
+                HackageUpdateMap
                 ) where
 
 import qualified Codec.Archive.Tar as Tar