bkr (empty) → 0.1.0
raw patch · 12 files changed
+1486/−0 lines, 12 filesdep +HDBCdep +HDBC-sqlite3dep +MissingHsetup-changed
Dependencies added: HDBC, HDBC-sqlite3, MissingH, aws, base, bytestring, directory, filepath, haskell98, hslogger, http-conduit, pureMD5, random, strict, text, unix, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bkr.cabal +79/−0
- src/Main.hs +69/−0
- src/System/Bkr/BkrConfig.hs +373/−0
- src/System/Bkr/BkrFundare.hs +31/−0
- src/System/Bkr/BkrLocalFile.hs +233/−0
- src/System/Bkr/BkrLocalMeta.hs +236/−0
- src/System/Bkr/BkrLogging.hs +53/−0
- src/System/Bkr/Hasher.hs +27/−0
- src/System/Bkr/TargetServices/S3/BkrAwsConfig.hs +49/−0
- src/System/Bkr/TargetServices/S3/BkrS3Bucket.hs +304/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Michael Smietana++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Michael Smietana nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bkr.cabal view
@@ -0,0 +1,79 @@+name: bkr+version: 0.1.0+synopsis: Backup utility for backing up to cloud storage services (S3 only right now)+description:+ Easy to use backup tool utilizing cloud services (S3 only right now) as backup storage.++ bkr is in very early development stage. Right now bkr is rather a synchronization then a backup utility. bkr uploads files from wanted folders to a remote storage service, next time it runs it checks for changes and uploads new or altered files but does not keep copies of altered files (hence rather synchronization then backup). For more information about installation and setup please visit "https://github.com/ingesson/bkr". All suggestions and bug reports are of course more then welcome.+license: BSD3+license-file: LICENSE+copyright: (c) 2012 Michael Smietana+author: Michael Smietana <michael@smietana.se>+maintainer: Michael Smietana <michael@smietana.se>+category: System, Backup+build-type: Simple+cabal-version: >= 1.8+tested-with: GHC == 7.0.4+homepage: https://github.com/ingesson/bkr+bug-reports: https://github.com/ingesson/bkr/issues ++library+ hs-source-dirs: src+ + exposed-modules: System.Bkr.Hasher+ , System.Bkr.BkrConfig+ , System.Bkr.BkrFundare+ , System.Bkr.BkrLogging+ , System.Bkr.BkrLocalFile+ , System.Bkr.BkrLocalMeta+ , System.Bkr.TargetServices.S3.BkrS3Bucket+ , System.Bkr.TargetServices.S3.BkrAwsConfig++ build-depends: base == 4.*+ , directory >= 1.0.1.2 && < 1.1.0.2+ , aws >= 0.3.1+ , haskell98 >= 1.1.0.0 && < 2.0.0.0+ , hslogger >= 1.1.5+ , strict >= 0.3.2+ , HDBC-sqlite3 >= 2.3.3.0+ , pureMD5 >= 2.1.0.3+ , MissingH >= 1.1.1.0+ , unix >= 2.5.0.0 && < 2.5.1.0+ , bytestring == 0.9.*+ , utf8-string == 0.3.*+ , text >= 0.11+ , filepath >= 1.1 && < 1.4+ , random == 1.0.0.3+ , HDBC >= 2.3.0.0+ , http-conduit >= 1.2.0+ + ghc-options: -O2 -Wall++executable bkr+ hs-source-dirs: src++ main-is: Main.hs+ + build-depends: base == 4.*+ , directory >= 1.0.1.2 && < 1.1.0.2+ , aws >= 0.3.1+ , haskell98 >= 1.1.0.0 && < 2.0.0.0+ , hslogger >= 1.1.5+ , strict >= 0.3.2+ , HDBC-sqlite3 >= 2.3.3.0+ , pureMD5 >= 2.1.0.3+ , MissingH >= 1.1.1.0+ , unix >= 2.5.0.0 && < 2.5.1.0+ , bytestring == 0.9.*+ , utf8-string == 0.3.*+ , text >= 0.11+ , filepath >= 1.1 && < 1.4+ , random == 1.0.0.3+ , HDBC >= 2.3.0.0+ , http-conduit >= 1.2.0+ + ghc-options: -O2 -Wall++source-repository head+ type: git+ location: https://github.com/ingesson/bkr.git
+ src/Main.hs view
@@ -0,0 +1,69 @@+{-|+bkr is meant to be an easy to use backup tool utilizing cloud services (S3 only right now) as backup storage.++bkr is in very early development stage. At the moment bkr is rather a synchronization then a backup utility. bkr uploads files from wanted folders to a remote storage service, next time it runs it checks for changes and uploads new or altered files but does not keep copies of altered files (hence rather synchronization then backup).++For more information about installation and setup please visit https://github.com/ingesson/bkr. All suggestions and bug reports are of course more then welcome.+-}++import System.Bkr.BkrFundare+import System.Bkr.BkrConfig+import System.Bkr.BkrLogging+import qualified System.Bkr.BkrLocalFile as F+import qualified System.Bkr.TargetServices.S3.BkrS3Bucket as S3B++import System.Directory (removeFile)+import Control.Monad (when)+import Data.Maybe (isNothing, fromJust)+--import Data.Global (declareIORef)+--import List (filter, zip3, concat)+--import Control.Monad (mapM, forM)+--import Data.Maybe (fromJust)+--import Data.String.Utils (split)++main :: IO ()+main = do+ + -- Check for valid configuration file and return () if it cannot be found (error message is shown by getConfFile).+ --print "will get conf file"+ confFile <- getConfFile+ when (isNothing confFile) (return ())+ + -- Set up logging+ --print "will set up logging"+ getLogLevel >>= setupLogging+ logNotice "Bkr started"+ logDebug $ "Using config file " ++ (fromJust confFile)+ + -- Get BkrMeta objects from S3+ logNotice "Getting Bkr files from S3"+ bkrS3Meta <- S3B.getBkrObjects++ -- Get local BkrMeta objects+ logNotice "Getting local files"+ --bkrLocalMeta <- getBackupFolders >>= mapM F.getBkrObjects+ bkrLocalMeta <- getBackupFolders >>= F.getBkrMetaForLocalPaths + + -- Filter objects to get local objects that are not backed up+ logNotice "Checking which files should be uploaded"+ --let objToUpload = filter (`notElem` bkrS3Meta) (concat bkrLocalMeta)+ let objToUpload = filter (`notElem` bkrS3Meta) bkrLocalMeta+ -- Create a list with a triple (bkrObj, no of bkrObj, nth bkrObj) to use as a counter+ let len = length objToUpload+ let counterList = zip3 objToUpload [len | _ <- [(1 :: Int)..]] [1..] -- We can use non ending lists since zip ends when the shortest (objToUpload) list ends. Got to love this lazy stuff.+ logNotice $ show len ++ " files will be uploaded"+ -- For each element in objToUpload upload the local file then create a .bkrm file and upload it+ _ <- mapM putFiles counterList+ logNotice "done" ++putFiles :: (BkrMeta, Int, Int) -> IO ()+putFiles (bkrObj, len, nthObj) = do+ + let localPath = fullPath bkrObj+ logNotice $ "Uploading " ++ show nthObj ++ "/" ++ show len ++ ": " ++ localPath+ -- Put local file+ S3B.putBackupFile localPath+ -- Get .bkrm file+ tmpFilePath <- writeBkrMetaFile (localPath, fileChecksum bkrObj)+ S3B.putBkrMetaFile tmpFilePath >> removeFile tmpFilePath+ --return ()
+ src/System/Bkr/BkrConfig.hs view
@@ -0,0 +1,373 @@++module System.Bkr.BkrConfig ( FileUpdateCheckType(..)+ , getConfPairsFromFile+ , getConfPairsFromFile'+ , getConfPairsFromFile_+ , getConfPairsFromFile_'+ , getConfPairsFromFileS+ , getConfPairsFromFileS'+ , getConfPairsFromByteString+ , getConfPairsFromByteString'+ , getConfFile+ , writeBkrMetaFile+ , getValue+ , getValueS+ , getBackupFolders+ , getFilesToIgnore+ , getFileExtensionsToIgnore+ , getFoldersToIgnore+ , getUseS3ReducedRedundancy+ , getLogLevel+ , getFileUpdateCheckType+ , getLogFileLocation+ , getLogFileMaximumSize+ ) where++--import Bkr.BkrLogging+import System.Bkr.Hasher++import System.IO+import System.Directory (getTemporaryDirectory, getModificationTime, doesFileExist, getHomeDirectory, copyFile, getTemporaryDirectory, getAppUserDataDirectory, createDirectoryIfMissing)+import System.FilePath.Posix (takeDirectory)+import Control.Monad (liftM)+import Data.String.Utils (split, strip, replace)+import Aws.S3.Model (StorageClass(..))+import System.Log.Logger (Priority(..))+import System.Environment (getArgs)+--import Data.Maybe (isNothing, fromJust)++import qualified System.IO.Strict as S+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T++--import System.IO+--import Data.List (lines)+--import Control.Monad (mapM)+--import List (find)+--import Data.Maybe (fromJust)+--import System.IO.Error (ioError, userError)++data FileUpdateCheckType = FUCChecksum+ | FUCDate+ | FUCSmart+ deriving Eq++{-| Read lines from s and filter on empty lines and lines beginning with # -}+getFilteredLines :: String -> [T.Text]+getFilteredLines s = [ x | x <- map T.pack (lines s), x /= T.empty, T.head (T.stripStart x) /= '#' ]++{-| Gets configuration pairs. This function takes a FilePath and reads the file lazy which might lead to unexpected consequences. If you want to have more control over the file handle use getConfPairsFromFile_ and if you want the file to be read strictly without the unwanted (or wanted) lazines side effects use getConfPairsFromFileS. -}+getConfPairsFromFile :: FilePath -> IO [(T.Text, T.Text)]+getConfPairsFromFile path = do+ --logDebug "getConfPairsFromFile called"+ -- Read the config file, split into lines and pack as Text+ hndl <- openBinaryFile path ReadMode+ readF <- hGetContents hndl+ + -- Just testing some styles. I'm not sure which one looks better, the first one is prabably easier to read.+ --return $ map getConfPair (getFilteredLines readF)+ return $ getConfPair `map` getFilteredLines readF++{-| Like getConfPairsFromFile but gets a String pair instead of Text. -}+getConfPairsFromFile' :: FilePath -> IO [(String, String)]+getConfPairsFromFile' path = --do+ --logDebug "getConfPairsFromFile' called"+ + --pairs <- getConfPairsFromFile path+ --return $ map textToString pairs+ getConfPairsFromFile path >>= return . map textToString++{-| Like getConfPairsFromFile but takes a file handle instead of FilePath. -}+getConfPairsFromFile_ :: Handle -> IO [(T.Text, T.Text)]+getConfPairsFromFile_ hndl = do+ --logDebug "getConfPairsFromFile_ called"+ -- Read the config file, split into lines and pack as Text+ readF <- hGetContents hndl++ return $ map getConfPair (getFilteredLines readF)++{-| Like getConfPairsFromFile' but takes a file handle instead of FilePath. -}+getConfPairsFromFile_' :: Handle -> IO [(String, String)]+getConfPairsFromFile_' hndl = --do+ --logDebug "getConfPairsFromFile_' called"+ + --pairs <- getConfPairsFromFile_ hndl+ --return $ map textToString pairs+ getConfPairsFromFile_ hndl >>= return . map textToString++{-| Like getConfPairsFromFile but reads file contents strictly. -}+getConfPairsFromFileS :: FilePath -> IO [(T.Text, T.Text)]+getConfPairsFromFileS path = do+ --logDebug "getConfPairsFromFileS called"+ -- Read the config file, split into lines and pack as Text+ hndl <- openBinaryFile path ReadMode+ -- Read contents strictly+ readF <- S.hGetContents hndl+ hClose hndl+ + return $ map getConfPair (getFilteredLines readF)++{-| Like getConfPairsFromFile' but reads file contents strictly. -}+getConfPairsFromFileS' :: FilePath -> IO [(String, String)]+getConfPairsFromFileS' path = --do+ --logDebug "getConfPairsFromFileS' called"++ --pairs <- getConfPairsFromFileS path+ --return $ map textToString pairs+ getConfPairsFromFileS path >>= return . map textToString++{-| Take a ByteString text, convert to lines and return Text pairs. -}+getConfPairsFromByteString :: BS.ByteString -> IO [(T.Text, T.Text)]+getConfPairsFromByteString bS = do+ --logDebug "getConfPairsFromByteString called"+ --let fileLines = map T.pack (lines $ BS.unpack bS)+ -- Get lines and filter lines beginning with #+ let fileLines = [ x | x <- map T.pack (lines $ BS.unpack bS), x /= T.empty, T.head (T.stripStart x) /= '#' ]+ return $ map getConfPair fileLines++{-| Like getConfPairsFromByteString but returns String. -}+getConfPairsFromByteString' :: BS.ByteString -> IO [(String, String)]+getConfPairsFromByteString' bS = --do+ --logDebug "getConfPairsFromByteString' called"++ --pairs <- getConfPairsFromByteString bS+ --return $ map textToString pairs+ getConfPairsFromByteString bS >>= return . map textToString++{-| Get a pair for Text line. |-}+getConfPair :: T.Text -> (T.Text, T.Text)+getConfPair line = (T.strip $ head s, T.strip $ last s)+ where s = T.split (==':') line++{-| Convert a Text pair to a String pair. |-}+textToString :: (T.Text, T.Text) -> (String, String)+textToString x = (T.unpack $ fst x, T.unpack $ snd x)++{-| Gets the value for a list of value pairs. The function matches on the first key found and does not check for multiple keys with the same name. If the key is not found Nothing is returned. -}+getValue :: T.Text -> [(T.Text, T.Text)] -> Maybe T.Text+getValue _ [] = Nothing+getValue key (x:xs) = if fst x == key+ then Just $ snd x+ else getValue key xs++{-| Same as getValue but for String value pairs |-}+getValueS :: String -> [(String, String)] -> Maybe String+--getValueS value values = lookup value values+getValueS = lookup++-- Bkr specific fuctions++{-| Take a bkr conf pair and write a .bkrm file in a temporary directory. -}+writeBkrMetaFile :: (String, String) -> IO FilePath+writeBkrMetaFile confPair = do+ --logDebug "writeBkrMetaFile called"+ -- Get tmp dir+ tmpDir <- getTemporaryDirectory+ -- Get hash of the file name+ let fullPathHash = show $ getHashForString $ fst confPair+ -- Get the full file path to the .bkrm file (<full path hash:file hash.bkrm>)+ let fullPath = tmpDir ++ fullPathHash ++ "." ++ snd confPair+ -- Get file modification time+ modTime <- getModificationTime $ fst confPair + -- Open a file handle+ hndl <- openBinaryFile fullPath WriteMode+ -- Map over a list of the lines to write to the file+ let hPutStrLnHndl = hPutStrLn hndl+ _ <- mapM hPutStrLnHndl ["[BkrMetaInfo]", + "fullpath: " ++ fst confPair, + "checksum: " ++ snd confPair, + "modificationtime: " ++ show modTime, + "fullpathchecksum: " ++ show (getHashForString $ fst confPair), + "modificationtimechecksum: " ++ show (getHashForString $ show modTime)]+ -- Close the handle and return the file path+ hClose hndl+ return fullPath++{-| Check if bkr.conf is passed as the first argument. We do not check if the bkr.conf file is valid, just that a file was passed as the first argument. -}+getArgIfValid :: IO (Maybe FilePath)+getArgIfValid = do+ args <- getArgs+ case args of+ [x] -> do+ fileExists <- doesFileExist x+ if fileExists+ then return $ Just x+ else return Nothing+ _ -> return Nothing++{-| Check if there is a bkr.conf file in the same directory as the bkr executable. We do not check that the bkr.conf file is valid, only if it exists. -}+getBkrConfFromDot :: IO (Maybe FilePath)+getBkrConfFromDot = do+ fileExists <- doesFileExist "./bkr.conf"+ if fileExists+ then return $ Just "./bkr.conf"+ else return Nothing++{-| Check if there is a $HOME/.bkr.conf file. We do not check if the .bkr.conf file is valid, only if it exists. If the file cannot be found the bkr.conf.example file is copied to $HOME/.bkr.conf and the user is instructed to edit it. -}+getBkrFromHomeDir :: IO (Maybe FilePath)+getBkrFromHomeDir = do+ homeDir <- getHomeDirectory+ let filePath = (++) homeDir "/.bkr.conf"+ fileExists <- doesFileExist filePath+ if fileExists+ then return $ Just filePath+ else do+ copyFile "./bkr.conf.example" filePath+ print $ "bkr configuration file could not be found. An example configuration file has been copied to your home directory, " ++ filePath ++ ". Please edit the configuration file and run bkr again."+ return Nothing++{-|+Gets file path to the Bkr configuration file. File locations checked (in order):+ 1. The first command line argument+ 2. ./bkr.conf+ 3. $HOME/.bkr.conf+-}+getConfFile :: IO (Maybe FilePath)+getConfFile = do+ argIfValid <- getArgIfValid+ case argIfValid of+ Just x -> return $ Just x+ _ -> do+ bkrFromDot <- getBkrConfFromDot+ case bkrFromDot of+ Just x -> return $ Just x+ _ -> do+ bkrFromHome <- getBkrFromHomeDir+ case bkrFromHome of+ Just x -> return $ Just x+ _ -> return Nothing+{-getConfFile = do+ argIfValid <- getArgIfValid+ when ((isNothing argIfValid) == False) (return argIfValid)++ bkrFromDot <- getBkrConfFromDot+ when ((isNothing bkrFromDot) == False) (return bkrFromDot)++ bkrFromHome <- getBkrFromHomeDir+ when ((isNothing bkrFromHome) == False) (return bkrFromHome)+ + return Nothing-}++getConfSetting :: String -> IO (Maybe String)+getConfSetting key = do+ confFile <- getConfFile+ case confFile of+ Just x -> liftM (getValueS key) (getConfPairsFromFileS' x)+ Nothing -> return Nothing++{-| Get a list of the folders to back up. If the setting cannot be found an IO Error is raised. -}+getBackupFolders :: IO [FilePath]+getBackupFolders = do+ --logDebug "getBackupFolders called"++ confSetting <- getConfSetting "folderstobackup"+ case confSetting of+ Just x -> return $ map strip (split "," x)+ Nothing -> ioError $ userError "Failed to find the configuration setting folderstobackup. Please check the configuration."++{-| Get a list of files to ignore. If the settings cannot be found an empty list is returned. -}+getFilesToIgnore :: IO [FilePath]+getFilesToIgnore = do+ --logDebug "getFilesToIgnore called"++ confSetting <- getConfSetting "filestoignore"+ case confSetting of+ Just x -> return $ map strip (split "," x)+ Nothing -> do+ --logDebug $ "getFilesToIgnore: " ++ "the setting filestoignore was not found."+ return []++{-| Get a list of files to ignore be extension. If the settings cannot be found an empty list is returned. -}+getFileExtensionsToIgnore :: IO [FilePath]+getFileExtensionsToIgnore = do+ --logDebug "getFileExtensionsToIgnore called"++ confSetting <- getConfSetting "fileextensionstoignore"+ case confSetting of+ Just x -> return $ map strip (split "," x)+ Nothing -> do+ --logDebug $ "getFileExtensionsToIgnore: " ++ "the setting fileextensionstoignore was not found."+ return []++{-| Get a list of folders to ignore. If the settings cannot be found an empty list is returned. -}+getFoldersToIgnore :: IO [FilePath]+getFoldersToIgnore = do+ --logDebug "getFoldersToIgnore called"++ confSetting <- getConfSetting "folderstoignore"+ case confSetting of+ Just x -> return $ map strip (split "," x)+ Nothing -> do+ --logDebug $ "getFoldersToIgnore: " ++ "the setting folderstoignore was not found."+ return []++{-| Get if we should use S3 reduced redundancy, if the setting cannot be found return reduced redundacy (there is not real reason not to use reduced redundancy for this kind of application. |-}+getUseS3ReducedRedundancy :: IO (Maybe StorageClass)+getUseS3ReducedRedundancy = do+ --logDebug "getUseS3ReducedRedundancy called"++ confSetting <- getConfSetting "uses3reducedredundancy"+ case confSetting of+ Just x -> if x == "yes"+ then return $ Just ReducedRedundancy+ else return $ Just Standard+ Nothing -> do+ --logDebug $ "getUseS3ReducedRedundancy: " ++ "the setting uses3reducedredundancy was not found."+ return $ Just ReducedRedundancy++{-| Get the log priority and default to debug if it could not be found or is misconfigured. -}+getLogLevel :: IO Priority+getLogLevel = do+ --print "getLogLevel called"++ confSetting <- getConfSetting "loglevel"+ case confSetting of+ Just x -> case x of+ "notify" -> return NOTICE+ "critical" -> return CRITICAL+ _ -> return DEBUG+ Nothing -> return DEBUG++{-| Get the file update check type, default to smart if it could not be found or is misconfigured. -}+getFileUpdateCheckType :: IO FileUpdateCheckType+getFileUpdateCheckType = do+ --logDebug "getFileUpdateCheckType called"++ confSetting <- getConfSetting "fileupdatecheck"+ case confSetting of+ Just x -> case x of+ "checksum" -> return FUCChecksum+ "date" -> return FUCDate+ _ -> return FUCSmart+ _ -> return FUCSmart++{-| Get log file location. $HOME, $TMP and $APPDATA are replaced with user's home directory, system temp directory and user's application data directory respectively. If the directory is not present it's created. -}+getLogFileLocation :: IO (Maybe FilePath)+getLogFileLocation = do+ confSetting <- getConfSetting "logfilelocation"+ case confSetting of+ Just x -> do+ homeDir <- getHomeDirectory+ tmpDir <- getTemporaryDirectory+ appDir <- getAppUserDataDirectory "bkr"+ let logFilePath = strReplace ["$HOME", "$TMP", "$APPDATA"] [homeDir, tmpDir, appDir] x ++ createDirectoryIfMissing True (takeDirectory logFilePath)++ return $ Just $ logFilePath+ _ -> return Nothing++ where strReplace :: [String] -> [String] -> String -> String+ strReplace (x:xs) (xR:xRs) s = strReplace xs xRs (replace x xR s)+ strReplace _ _ s = s++{-| Get log file maximum size in bytes. If the size cannot be found default to 5MB. -}+getLogFileMaximumSize :: IO Int+getLogFileMaximumSize = do+ confSetting <- getConfSetting "logfilemaximumsize"+ case confSetting of+ Just x -> return $ rInt x+ _ -> return 5242880+ + where rInt :: String -> Int+ rInt = read
+ src/System/Bkr/BkrFundare.hs view
@@ -0,0 +1,31 @@++module System.Bkr.BkrFundare ( BkrMeta(..)+ , getBkrMeta+ ) where++import System.Bkr.Hasher++import System.Directory (getModificationTime)++data BkrMeta = BkrMeta { fullPath :: FilePath+ , fileChecksum :: String+ , pathChecksum :: String+ , modificationTime :: String+ , modificationTimeChecksum :: String+ } deriving Show++{-|+True for:+fileChecksum && pathChecksum+or+pathChecksum && modificationTimeChecksum+-}+instance Eq BkrMeta where+ meta1 == meta2 = (fileChecksum meta1 == fileChecksum meta2 && pathChecksum meta1 == pathChecksum meta2) || (pathChecksum meta1 == pathChecksum meta2 && modificationTimeChecksum meta1 == modificationTimeChecksum meta2)++{-| Gets BkrMeta for a FilePath. -}+getBkrMeta :: FilePath -> IO BkrMeta+getBkrMeta path = do+ fileHash <- getFileHash path+ modTime <- getModificationTime path+ return $ BkrMeta path (show fileHash) (show $ getHashForString path) (show modTime) (show $ getHashForString $ show modTime)
+ src/System/Bkr/BkrLocalFile.hs view
@@ -0,0 +1,233 @@++{-# LANGUAGE ScopedTypeVariables #-}++module System.Bkr.BkrLocalFile ( getBkrMetaForLocalPaths+ --, getBkrObjects+ --, getAllFolders+ --, getAllFiles+ ) where++import System.Bkr.Hasher+import System.Bkr.BkrFundare+import System.Bkr.BkrLocalMeta+import System.Bkr.BkrConfig (getFilesToIgnore, getFileExtensionsToIgnore, getFoldersToIgnore, getFileUpdateCheckType, FileUpdateCheckType(..))++import Control.Monad (filterM, liftM)+import System.Directory (doesDirectoryExist, getDirectoryContents, doesFileExist, getModificationTime)+import System.FilePath ((</>), normalise, takeExtensions, takeDirectory)+import Prelude hiding (catch)+import Control.Exception++--import Data.Digest.Pure.MD5 (md5, MD5Digest)+--import qualified Data.ByteString.Lazy as L++{-| Filter [FilePath] on file extension. The first argument is a list with file extensions to filter on (for example [\".txt\", \".doc\"]) and the second a list of the file paths to filter. -}+filterExt :: [FilePath] -> [FilePath] -> [FilePath]+filterExt ignoreList = filter (\x -> takeExtensions x `notElem` ignoreList)++{-| Filter [FilePath] on folders. The first argument is a list with folders to filter on (for example [\"/Users/username/donotbackup\", \"/Users/username/donotbackupeither\"] and the second a list of the file paths to filter. -}+filterFolder :: [FilePath] -> [FilePath] -> [FilePath]+filterFolder ignoreList = filter (\x -> takeDirectory x `notElem` ignoreList)++{-| Filter [FilePath] on files. The first argument is a list with files to filter on (for example [\"donotbackup\", \"donotbackupeither\"] and the second a list of the file paths to filter. -}+filterFile :: [FilePath] -> [FilePath] -> [FilePath]+--filterFile ignoreList = filter (\x -> x `notElem` ignoreList)+filterFile ignoreList = filter (`notElem` ignoreList)++{-| Handle IOException. Check if the passed FilePath is a file and return [FilePath] if it is and [] if not. Used, for instance, if you want to make sure that you don't miss a file if FilePath passed to getDirectoryContents is a file. -}+handleIOReturnIfFile :: IOException -> FilePath -> IO [FilePath]+handleIOReturnIfFile _ path = do+ pathIsFile <- doesFileExist path+ if pathIsFile+ then return [path]+ else return []++{-| Get files to ignore from bkr.conf and add some default files that always should be ignored. -}+getFilesToFilter :: IO [FilePath]+getFilesToFilter = --do+ --filesToFilter <- getFilesToIgnore+ --return $ [".", "..", ".bkrmeta"] ++ filesToIgnore+ getFilesToIgnore >>= return . (++) [".", "..", ".bkrmeta"]++{-| Get all files for a given folder filtered on file extension and files to ignore. -}+getFilesInFolder :: FilePath -> IO [FilePath]+getFilesInFolder path = do+ names <- getDirectoryContents path `catch` \ (ex :: IOException) -> handleIOReturnIfFile ex path+ filesToIgnore <- getFilesToFilter+ fileExtToIgnore <- getFileExtensionsToIgnore+ -- Filter files on extension and files to ignore+ let properNames = filterExt fileExtToIgnore $ filterFile filesToIgnore names+ -- Map files with topPath to get full path and filter on files+ filterM doesFileExist (map (path </>) properNames)++{-| Get all folders for a given path filtered on folders to ignore. -}+getAllFolders :: FilePath -> IO [FilePath]+getAllFolders topPath = do+ names <- getDirectoryContents topPath `catch` \ (_ :: IOException) -> return []+ -- Map files with topPath to get full path and filter on folders to ignore+ foldersToIgnore <- getFoldersToIgnore+ let paths = filterFolder foldersToIgnore $ map ((</>) topPath) (filterFile [".", ".."] names)+ folders <- filterM doesDirectoryExist paths+ allFolders <- mapM getAllFolders folders++ return $ map normalise (concat allFolders ++ folders)++{-| Get a BkrMeta for only path and modification time that can be used with BkrMeta_ for Eq on path and modification time checksum. -}+getBkrMeta_ :: FilePath -> IO BkrMeta+getBkrMeta_ path = do+ modTime <- getModificationTime path+ return $ BkrMeta path "" (show $ getHashForString path) "" (show $ getHashForString $ show modTime)++{-| +Get file update check type:+ checksum -> do not check .bkrmeta files+ date and smart -> pass type to getLocalMeta +-}+getCachedBkrMetaList :: FilePath -> IO [BkrMeta]+getCachedBkrMetaList dotbkrmetaFile = do+ updateFileCheck <- getFileUpdateCheckType+ if updateFileCheck == FUCChecksum+ then return []+ else do + -- Check that the .bkrmeta file exist and get all cached BkrMeta objects+ bkrMetaFile <- filterM doesFileExist [dotbkrmetaFile]+ let getLocalMeta' = getLocalMeta updateFileCheck+ --cachedBkrMetaList <- mapM getLocalMeta' bkrMetaFile+ --return $ concat cachedBkrMetaList+ mapM getLocalMeta' bkrMetaFile >>= return . concat++{-| +For given FilePath:+ - Get all BkrMeta objects from .bkrmeta (if it exists)+ - Check if the .bkrmeta objects are valid or should be updated according to file update check type (see getCachedBkrMetaList)+ - Update .bkrmeta by inserting new and updated objects and deleting objects for files that have been deleted+ - Return all BkrMeta objects for the given FilePath+-}+folderCompareAndGetBkrMeta :: FilePath -> IO [BkrMeta]+folderCompareAndGetBkrMeta path = do+ let dotbkrmetaFile = path ++ "/.bkrmeta"++ -- Get all files in folder and getBkrMeta_ them (getBkrMeta_ does not get all BkrMeta items since folderBkrMetaList is only going to be used for filtering which files are not cached in .bkrmeta)+ --filesInFolder <- getFilesInFolder path+ --folderBkrMetaList <- mapM getBkrMeta_ filesInFolder+ folderBkrMetaList <- getFilesInFolder path >>= mapM getBkrMeta_++ -- Get all cached BkrMeta objects and mind file update check type setting; checksum -> do not check .bkrmeta files (get checksum for all files every time), date (check by file change date) and smart (get the checksum randomly but always at least every tenth run).+ cachedBkrMetaList' <- getCachedBkrMetaList dotbkrmetaFile++ -- Get all cached files that has been deleted from the disk and delete them from the .bkrmeta file+ let deletedCachedFiles = filter (`notElem` folderBkrMetaList) cachedBkrMetaList'+ deleteBkrMeta dotbkrmetaFile deletedCachedFiles+ -- Get the cached files that has not been deleted from disk+ let cachedBkrMetaList = filter (`notElem` deletedCachedFiles) cachedBkrMetaList'+ + -- Get all files that are in folderBkrMetaList but not in cachedBkrMetaList+ let notCachedBkrMetaList = filter (`notElem` cachedBkrMetaList) folderBkrMetaList+ + -- Get "real" BkrMeta objects and update .bkrmeta file with notCachedBkrMetaList+ let notCachedPaths = map fullPath notCachedBkrMetaList+ notCachedBkrMeta <- mapM getBkrMeta notCachedPaths+ insertBkrMeta dotbkrmetaFile notCachedBkrMeta+ + -- Return cached and not cached BkrMeta objects+ return $ notCachedBkrMeta ++ cachedBkrMetaList++{-| Get all BkrMeta objects for a list of folders using .bkrmeta cached objects according to the bkr.conf fileupdatecheck setting. -}+getBkrMetaForLocalPaths :: [FilePath] -> IO [BkrMeta]+getBkrMetaForLocalPaths paths = do+ allPaths <- mapM getAllFolders paths+ --bkrMeta <- mapM folderCompareAndGetBkrMeta (concat allPaths ++ paths)+ --return $ concat bkrMeta+ --mapM folderCompareAndGetBkrMeta (concat allPaths ++ paths) >>= return . concat+ liftM concat (mapM folderCompareAndGetBkrMeta ((++) paths (concat allPaths)))++{-+getBkrMeta'' :: [FilePath] -> IO [BkrMeta]+getBkrMeta'' paths = do+ -- Get all folders, combine with .bkrmeta file for full file path to the .bkrmeta files, filter to to check which .bkrmeta files exist, get BkrMeta objects and finally get BkrMeta_ objects+ allFolders <- mapM getAllFolders paths+ allBkrLocalMetaFiles <- filterM doesFileExist (map combine_ (concat allFolders))+ localMetaDB <- mapM getLocalMeta allBkrLocalMetaFiles+ let localMeta_ = map BkrMeta_ (concat localMetaDB)+ + -- Get all files+ allFiles <- mapM getAllFiles paths+ localMetaFiles <- mapM getBkrMeta (concat allFiles)+ let localMetaFiles_ = map BkrMeta_ localMetaFiles+ let notCached = filter (`notElem` localMeta_) localMetaFiles_++ let allFiles = map fullPath (map bkrMeta notCached)++ notCachedMeta <- mapM getBkrMeta allFiles --(fullPath (BkrMeta notCached))+++ --let allMeta = (concat localMetaDB) ++ notCachedMeta++ return $ (concat localMetaDB) ++ notCachedMeta+-}+{-+getAllFiles :: FilePath -> IO [FilePath]+getAllFiles topPath = do+ names <- getDirectoryContents topPath `catch` \ (ex :: IOException) -> handleIO ex topPath+ --filesToIgnore <- getFilesToIgnore+ filesToIgnore <- getFilesToFilter+ fileExtToIgnore <- getFileExtensionsToIgnore+ foldersToIgnore <- getFoldersToIgnore+ -- Filter files on extension and files to ignore+ --let properNames = (filterExt fileExtToIgnore) $ filterFile ([".", "..", ".bkrmeta"] ++ filesToIgnore) names+ let properNames = filterExt fileExtToIgnore $ filterFile filesToIgnore names+ -- Map files with topPath to get full path and filter on folders to ignore+ let allPaths = filterFolder foldersToIgnore $ map (topPath </>) properNames+ paths <- forM allPaths $ \path -> do+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then getAllFiles path+ else return [normalise path]+ return $ concat paths+-}+{-+getAllFilesOld :: FilePath -> IO [FilePath]+getAllFilesOld topPath = do+ names <- getDirectoryContents topPath `catch` \ (ex :: IOException) -> handleIO ex topPath+ --filesToIgnore <- getFilesToIgnore+ filesToIgnore <- getFilesToFilter+ --let properNames = filter (`notElem` ([".", ".."] ++ filesToIgnore)) names+ let properNames = filter (`notElem` (filesToIgnore)) names+ print $ show properNames+ paths <- forM properNames $ \name -> do+ let path = topPath </> name+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then getAllFiles path+ else return [normalise path]+ return $ concat paths+-}+{-+getBkrMeta :: FilePath -> IO BkrMeta+getBkrMeta path = do+ fileHash <- getFileHash path+ return $ BkrMeta path (show fileHash) (show $ getHashForString path)+-}+{-+getBkrObjects :: FilePath -> IO [BkrMeta]+getBkrObjects path = --do+ --allFiles <- getAllFiles path+ --mapM getBkrMeta allFiles+ getAllFiles path >>= mapM getBkrMeta+-}+{-+getLocalBkrObjects :: FilePath -> IO [BkrMeta]+getLocalBkrObjects path = do+ folders <- getAllFolders path+ return $ mapM getBkrMetaFromDB folders+-}+{-+getBkrMeta' :: FilePath -> IO [BkrMeta]+getBkrMeta' = do+ folders <- getAllFolders path+ return $ concat $ map getBkrMeta'' folders+-}+{-+combine_ :: FilePath -> FilePath+combine_ path = (++) path "/.bkrmeta"+-}
+ src/System/Bkr/BkrLocalMeta.hs view
@@ -0,0 +1,236 @@++{-# LANGUAGE ScopedTypeVariables #-}++module System.Bkr.BkrLocalMeta ( getLocalMeta+ , insertBkrMeta+ , deleteBkrMeta+ ) where++import System.Bkr.BkrLogging+import System.Bkr.BkrFundare+import System.Bkr.BkrConfig (FileUpdateCheckType(..))+--import Bkr.Hasher (getHashForString)++import Database.HDBC+import Database.HDBC.Sqlite3 as SL++import Prelude hiding (catch)+import Control.Exception (catch)+import System.Random (getStdRandom, randomR)+import Control.Monad (filterM)++--import System.Time (ClockTime(..))++-- db convenience functions --++{-| Convenience function for getting a db connection. -}+getConn :: FilePath -> IO SL.Connection+getConn path = do+ logDebug $ "getSqliteConnection: getting conn for path: " ++ path+ + -- Try usong connectSqlite3 and connectSqlite3Raw if that fails (file system unicode support workaround for OS X)+ SL.connectSqlite3 path `catch` \ (_ :: SqlError) -> SL.connectSqlite3Raw path++{-| Convenience function for disconnection a db connection. -}+doDisconnect :: IConnection conn => conn -> IO ()+doDisconnect conn = logDebug "doDisconnect called" >> disconnect conn++{-| Convenience function for committing a ongoing transaction. -}+doCommit :: IConnection conn => conn -> IO ()+doCommit conn = logDebug "doCommit called" >> commit conn++{-| Convenience function for rolling back a transaction. -}+doRollback :: IConnection conn => conn -> IO ()+doRollback conn = logDebug "doRollback called" >> rollback conn++{-| Convenience function for db insert. Takes file path to the db file and commits the transaction automatically.++Use as:+@+set \"/path/to/db/file.db\" \"INSERT INTO table VALUES (?, ?)\" [[toSql (1 :: Int), toSql (\"text\" :: String)], [toSql (2 :: Int), SqlNull]]+@+-}+set :: FilePath -> String -> [[SqlValue]] -> IO ()+set dbFilePath query values = do + logDebug $ "set: called with query: " ++ query -- ++ "\nvalues: " ++ (show values)+ conn <- getConn dbFilePath+ catch (do + stmt <- prepare conn query+ executeMany stmt values+ doCommit conn)+ --doDisconnect conn)+ (\e -> do + let err = show (e :: SqlError)+ logCritical $ "set: got SqlError: " ++ err ++ ", will rollback the transaction"+ doRollback conn+ doDisconnect conn)++-- End db convenience functions --++{-| Created a .bkrmeta db file and inserts the bkrmeta table. -}+setTable :: FilePath -> IO ()+setTable dbFilePath = do+ logDebug $ "setTable: called for path: " ++ dbFilePath+ + let query = "CREATE TABLE IF NOT EXISTS bkrmeta (pathchecksum TEXT PRIMARY KEY, fullpath TEXT NOT NULL, filechecksum TEXT NOT NULL, filemodtimechecksum TEXT NOT NULL, filemodtime TEXT, nogets INTEGER)"+ set dbFilePath query [[]]++{-| Filter function that gets a random number between 0-9 and checks if the number is larger then noGets. If larger returns IO True (object is read from the local db) and if smaller the object is deleted from the local db (insertBkrMeta will insert the object). -}+objUpdateFilter :: IConnection conn => conn -> [SqlValue] -> IO Bool+--objUpdateFilter conn [pathChecksum, fullPath, fileChecksum, fileModTime, fileModChecksum, noGets] = do+objUpdateFilter conn [pathChecksum_, fullPath_, _, _, _, noGets_] = do+ randomNo <- getStdRandom (randomR (0,9))+ if randomNo > noGets_'+ then return True+ else do+ print $ "objUpdateFilter: will delete obj: " ++ show fullPath_+ let query = "DELETE FROM bkrmeta WHERE pathchecksum = ?"+ _ <- quickQuery' conn query [pathChecksum_] `catch` \ (err :: SqlError) -> do+ logCritical $ "objUpdateFilter: got sql error: " ++ show err+ return []+ return False++ where noGets_' = fromSql noGets_ :: Int+objUpdateFilter _ _ = error "Failed to match expected pattern"++{-| Gets BkrMeta objects from a .bkrmeta db file. getLocalMeta increments nogets every time it's called and it filters objects with objUpdateFilter. -}+getLocalMeta :: FileUpdateCheckType -> FilePath -> IO [BkrMeta]+getLocalMeta fileUpdateCheckType dbFilePath = do+ logDebug $ "getLocalMeta: called for path: " ++ dbFilePath+ + conn <- getConn dbFilePath+ let query = "SELECT pathchecksum, fullpath, filechecksum, filemodtime, filemodtimechecksum, nogets FROM bkrmeta"+ result <- quickQuery' conn query [] `catch` \ (err :: SqlError) -> do+ logCritical $ "getLocalMeta: got sql error: " ++ show err ++ ", will disconnect conn"+ doDisconnect conn+ return []+ -- Increment nogets+ let query_ = "UPDATE bkrmeta SET nogets = nogets + 1"+ _ <- quickQuery' conn query_ [] `catch` \ (err :: SqlError) -> do+ logCritical $ "getLocalMeta: got sql error when incrementing nogets: " ++ show err ++ ", will disconnect conn"+ doDisconnect conn+ return []+ -- Use smart update or check by date only+ if fileUpdateCheckType == FUCSmart+ then do+ --filteredObjects <- filterM (\x -> objUpdateFilter conn x) result+ filteredObjects <- filterM (objUpdateFilter conn) result+ doCommit conn+ doDisconnect conn+ return $ map convRow filteredObjects+ else do+ doCommit conn+ doDisconnect conn+ return $ map convRow result++ where convRow :: [SqlValue] -> BkrMeta+ --convRow [pathChecksum, fullPath, fileChecksum, fileModTime, fileModChecksum, noGets] = + convRow [pathChecksum_, fullPath_, fileChecksum_, fileModTime_, fileModChecksum_, _] = + BkrMeta path fileHash pathHash fileMod fileModHash+ where path = fromSql fullPath_ :: String+ fileHash = fromSql fileChecksum_ :: String+ pathHash = fromSql pathChecksum_ :: String+ fileMod = fromSql fileModTime_ :: String+ fileModHash = fromSql fileModChecksum_ :: String+ convRow _ = error "Failed to match expected pattern"++{-| Checks if bkrmeta table exists and inserts it if it doesn't. -}+setTableIfNeeded :: FilePath -> IO ()+setTableIfNeeded dbFilePath = do+ logDebug $ "setTableIfNeeded: called for path: " ++ dbFilePath+ conn <- getConn dbFilePath+ catch (do+ --result <- quickQuery' conn "SELECT * FROM bkrmeta LIMIT 1" []+ _ <- quickQuery' conn "SELECT * FROM bkrmeta LIMIT 1" []+ doDisconnect conn+ logDebug "setTableIfNeeded: table exists"+ return ())+ (\e -> do + let err = show (e :: SqlError)+ logDebug $ "setTableIfNeeded: got sql error: " ++ err ++ ", will set table"+ doDisconnect conn+ setTable dbFilePath)++{-| Inserts BkrMeta objects into a .bkrmeta db file. -}+insertBkrMeta :: FilePath -> [BkrMeta] -> IO ()+insertBkrMeta dbFilePath bkrMetaList = do+ logDebug $ "insertBkrMeta: called for path: " ++ dbFilePath+ + let valuesList = map getValList bkrMetaList+ let query = "INSERT INTO bkrmeta (pathchecksum, fullpath, filechecksum, filemodtimechecksum, filemodtime, nogets) VALUES (?,?,?,?,?,?)"++ setTableIfNeeded dbFilePath+ set dbFilePath query valuesList++ where getValList :: BkrMeta -> [SqlValue]+ getValList bkrMeta = [toSql (pathChecksum bkrMeta :: String),+ toSql (fullPath bkrMeta :: String),+ toSql (fileChecksum bkrMeta :: String),+ toSql (modificationTimeChecksum bkrMeta :: String),+ toSql (modificationTime bkrMeta :: String), + toSql (0 :: Int)]++{-| Delete BkrMeta objects from a .bkrmeta file. -}+deleteBkrMeta :: FilePath -> [BkrMeta] -> IO ()+deleteBkrMeta dbFilePath bkrMetaList = do+ logDebug $ "deleteBkrMeta: called for path: " ++ show dbFilePath+ + let valuesList = map getValList bkrMetaList+ let query = "DELETE FROM bkrmeta WHERE pathchecksum = ?"+ + setTableIfNeeded dbFilePath+ + set dbFilePath query valuesList++ where getValList :: BkrMeta -> [SqlValue]+ getValList bkrMeta = [toSql (pathChecksum bkrMeta :: String)]++{-+{-| Convenience function for db insert, same as set but takes an established db connection instead. You need to create the connection and commit the query manually.++Use as:+@+conn <- getSqliteConnection "pathToDBFile.db"+set' conn "INSERT INTO table VALUES (?, ?)" [[toSql (1 :: Int), toSql ("text" :: String)],[toSql (2 :: Int), SqlNull]]+doCommit conn+doDisconnect conn+@+|-}+set' :: IConnection conn => conn -> String -> [[SqlValue]] -> IO ()+set' conn query values = do + logDebug $ "set': called with query: " ++ query+ catch (do + stmt <- prepare conn query+ executeMany stmt values)+ (\e -> do + let err = show (e :: SqlError)+ logCritical $ "set': got SqlError: " ++ err ++ ", will rollback the transaction"+ doRollback conn)+-}++{-+setSimple :: IConnection conn => conn -> String -> [SqlValue] -> IO Integer+setSimple conn query values = do+ logDebug $ "setSimple: called with query: " ++ query+ run conn query values `catch` (\e -> do + let err = show (e :: SqlError)+ logCritical $ "setSimple: got SqlError: " ++ err ++ ", will rollback the transaction"+ doRollback conn+ return 0)+-}++{-+getValuesList :: FilePath -> String -> ClockTime -> Int -> [SqlValue]+getValuesList fullPath fileChecksum fileModTime noGets = [toSql ((show $ getHashForString fullPath) :: String), toSql (fullPath :: String), toSql (fileChecksum :: String), toSql ((show $ getHashForString $ show fileModTime) :: String), toSql (fileModTime :: ClockTime), toSql (noGets :: Int)]+++insertBkrMeta :: FilePath -> String -> String -> ClockTime -> IO ()+insertBkrMeta dbFilePath fullPath fileChecksum fileModTime = do+ --logDebug $ "insertBkrMeta: called for path: " ++ dbFilePath+ --conn <- getConn dbFilePath+ let query = "INSERT INTO bkrmeta (pathchecksum, fullpath, filechecksum, filemodtimechecksum, filemodtime, nogets) VALUES (?,?,?,?,?,?)"+ --set conn query [getValuesList fullPath fileChecksum fileModTime 0]+ --doCommit conn+ --doDisconnect conn+ set dbFilePath query [getValuesList fullPath fileChecksum fileModTime 0]+-}
+ src/System/Bkr/BkrLogging.hs view
@@ -0,0 +1,53 @@++module System.Bkr.BkrLogging ( setupLogging+ , logDebug+ , logNotice+ , logCritical+ ) where++import System.Bkr.BkrConfig (getLogFileLocation, getLogFileMaximumSize)++import System.Log.Logger+import System.Log.Handler.Simple+import System.Log.Formatter+import System.Log.Handler (setFormatter)+import Data.Maybe (fromJust)+import System.Posix.Files (getFileStatus, fileSize)+import System.Directory (removeFile)+import Control.Monad (when)++--import System.Log.Handler.Growl++setupLogging :: Priority -> IO ()+setupLogging logLevel = do+ -- Get log file location+ logFilePath <- getLogFileLocation+ --print $ show logFilePath+ -- Check if we got a log file, if not set up logging to stderr otherwise set up file logging+ if logFilePath == Nothing+ then do+ putStrLn "Could not find log file, please make sure to set the log file path correctly in bkr settings. Will log to stderr."+ updateGlobalLogger "bkrfile" (setLevel logLevel)+ else do+ -- Check that the log file hasn't reached maximum size and recycle if it has+ logFileMaxSize <- getLogFileMaximumSize+ fileStatus <- getFileStatus (fromJust logFilePath)+ let logFileSize = fileSize fileStatus+ when ((read (show logFileSize) :: Int) > logFileMaxSize) (removeFile $ fromJust logFilePath)++ -- File handler+ h <- fileHandler (fromJust logFilePath) DEBUG >>= \lh -> return $ setFormatter lh (tfLogFormatter "%F %X.%q" "$time|$loggername|$prio: $msg")+ + -- Update global logger with handler and log level+ updateGlobalLogger "bkrfile" (addHandler h)+ updateGlobalLogger "bkrfile" (setLevel logLevel)+ ++logDebug :: String -> IO ()+logDebug = debugM "bkrfile"++logNotice :: String -> IO ()+logNotice = noticeM "bkrfile"++logCritical :: String -> IO ()+logCritical = criticalM "bkrfile"
+ src/System/Bkr/Hasher.hs view
@@ -0,0 +1,27 @@+++module System.Bkr.Hasher ( getFileHash+ , getHashForString+ ) where++import Data.Digest.Pure.MD5 (md5, MD5Digest)++import qualified Data.ByteString.Lazy.UTF8 as UBL+import qualified Data.ByteString.Lazy as BL++{-| Gets a MD5Digest for a file. -}+getFileHash :: FilePath -> IO MD5Digest+getFileHash path = do+ --L.readFile path >>= return . md5+ + readF <- BL.readFile path+ return $! md5 readF++{-| Gets a MD5Digest for a String. Example:++@+print $ show $ getHashForString \"sdknafsfadsäöåfas\"+@+-}+getHashForString :: String -> MD5Digest+getHashForString = md5 . UBL.fromString
+ src/System/Bkr/TargetServices/S3/BkrAwsConfig.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Bkr.TargetServices.S3.BkrAwsConfig ( getS3Config+ , getS3BucketName+ ) where++import System.Bkr.BkrConfig++import Aws.Aws+import Aws.Credentials+import Aws.Http+import Aws.S3.Info+import Aws.Ses.Info+import Aws.Signature+import Aws.SimpleDb.Info+import Aws.Sqs.Info+import Data.Maybe (fromJust)+import Control.Monad (liftM)++import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T++getS3Config :: IO Configuration+getS3Config = do+ -- Get AWS access and secret keys from bkr.conf+ confPairs <- getConfFile >>= getConfPairsFromFileS' . fromJust+ let cr = Credentials (B.pack $ fromJust $ lookup "awsaccesskeyid" confPairs) (B.pack $ fromJust $ lookup "awssecretaccesskey" confPairs)+ + return Configuration { timeInfo = Timestamp+ , credentials = cr+ , sdbInfo = sdbHttpsPost sdbUsEast+ , sdbInfoUri = sdbHttpsGet sdbUsEast+ , s3Info = s3 HTTP s3EndpointUsClassic False+ , s3InfoUri = s3 HTTP s3EndpointUsClassic True+ , sqsInfo = sqs HTTP sqsEndpointUsClassic False+ , sqsInfoUri = sqs HTTP sqsEndpointUsClassic True+ , sesInfo = sesHttpsPost sesUsEast+ , sesInfoUri = sesHttpsGet sesUsEast+ , logger = defaultLog Warning+ }++getS3BucketName :: IO T.Text+--getS3BucketName = do+ --confPairs <- getConfPairsFromFileS' "bkr.conf"+ --return $ T.pack $ fromJust $ lookup "s3bucketname" confPairs+ +--getS3BucketName = getConfPairsFromFileS' "bkr.conf" >>= return . T.pack . fromJust . lookup "s3bucketname"++getS3BucketName = liftM (T.pack . fromJust . lookup "s3bucketname") (getConfFile >>= getConfPairsFromFileS' . fromJust)
+ src/System/Bkr/TargetServices/S3/BkrS3Bucket.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++module System.Bkr.TargetServices.S3.BkrS3Bucket ( getBkrObjects+ , putBackupFile+ , putBkrMetaFile+ ) where++import System.Bkr.BkrConfig+import System.Bkr.BkrFundare+import System.Bkr.Hasher+import System.Bkr.BkrLogging+import System.Bkr.TargetServices.S3.BkrAwsConfig++import System.IO+import Network.HTTP.Conduit+import Data.IORef (newIORef, readIORef)+import Data.Monoid (mempty)+import System.FilePath.Posix (takeFileName)+import Prelude hiding (catch)+import Control.Concurrent (threadDelay)++import qualified Aws+import qualified Aws.S3 as S3+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Control.Exception as C++--import System.IO.Error (ioError, userError)+--import Data.Conduit (($$))+--import Data.Conduit.Binary (sinkIOHandle)+--import Maybe (fromJust)+--import Control.Monad (forM)+--import System.Directory (getTemporaryDirectory, removeFile)+--import Data.ByteString (pack)+--import qualified Data.Knob as K+--import qualified Data.ByteString.Lazy.UTF8 as B+--import qualified Data.ByteString.UTF8 as BUTF8+--import qualified Data.ByteString.Lazy as LB++getBkrObjectKeys :: T.Text -> [T.Text] -> IO [T.Text]+getBkrObjectKeys gbMarker objList = do++ -- Get AWS credentials+ cfg <- getS3Config+ + -- Create an IORef to store the response Metadata (so it is also available in case of an error).+ metadataRef <- newIORef mempty+ + -- Get bucket info with simpleAwsRef. S3.getBucket returns a GetBucketResponse object.+ bucketName <- getS3BucketName+ -- add catch S3Error and print check aws settings. + s3BkrBucket <- Aws.simpleAwsRef cfg metadataRef S3.GetBucket { S3.gbBucket = bucketName+ , S3.gbDelimiter = Nothing+ , S3.gbMarker = Just gbMarker+ , S3.gbMaxKeys = Nothing+ , S3.gbPrefix = Just $ T.pack "bkrm"+ } `C.catch` \ (ex :: C.SomeException) -> do+ logCritical "Failed to get objects from the S3 bucket, please check that your S3 credentials in the bkr configuration file are set correctly. The error was:"+ C.throwIO ex+ + -- Print the response metadata.+ --print =<< readIORef metadataRef+ -- Log the response metadata.+ ioResponseMetaData <- readIORef metadataRef+ logDebug $ "getBkrObjectKeys: response metadata: " ++ show ioResponseMetaData++ -- Get bucket contents with gbrContents. gbrContents gets [ObjectInfo]+ let bkrBucketContents = S3.gbrContents s3BkrBucket+ + -- Get object keys (the bkr object filenames)+ let objects = map S3.objectKey bkrBucketContents++ -- S3 is limited to fetch 1000 objects so make sure that we get all objects+ if length objects > 999+ then getBkrObjectKeys (last objects) (objList ++ objects)+ else return $ objList ++ objects++getBkrObjects :: IO [BkrMeta]+getBkrObjects = do+ + objectKeys <- getBkrObjectKeys (T.pack "") []+ logNotice $ "Got " ++ show (length objectKeys) ++ " objects from S3"++ return $ map getMetaKeys objectKeys++getMetaKeys :: T.Text -> BkrMeta+getMetaKeys key = BkrMeta { fullPath = "" + , pathChecksum = T.unpack $ kSplit !! 1+ , fileChecksum = T.unpack $ kSplit !! 2+ , modificationTime = ""+ , modificationTimeChecksum = ""+ }+ where kSplit = T.split (=='.') key++putBackupFile :: FilePath -> IO ()+putBackupFile filePath = do+ + let uploadName = T.pack $ show (getHashForString filePath) ++ "::" ++ takeFileName filePath+ -- Get MD5 hash for file+ --contentMD5 <- getFileHash path+ --putFile path uploadName (Just $ BUTF8.fromString $ show contentMD5)+ putFile filePath uploadName Nothing 0++putBkrMetaFile :: FilePath -> IO ()+putBkrMetaFile filePath = do++ let uploadName = T.pack $ "bkrm." ++ takeFileName filePath+ -- Get MD5 hash for file+ --contentMD5 <- getFileHash path+ --putFile path uploadName (Just $ BUTF8.fromString $ show contentMD5)+ putFile filePath uploadName Nothing 0++{-| Upload file to S3. putFile will handle a failed attempt to upload the file by waiting 60 seconds and then retrying. If this fails five times it will raise an IO Error.+|-}+putFile :: FilePath -> T.Text -> Maybe B.ByteString -> Int -> IO ()+putFile filePath uploadName contentMD5 noOfRetries =+ putFile' filePath uploadName contentMD5 `C.catch` \ (ex :: C.SomeException) ->+ if noOfRetries > 5+ then ioError $ userError $ "Failed to upload file " ++ filePath+ else do+ logCritical $ "putFile: got exception: " ++ show ex+ logCritical "Wait 60 sec then try again"+ threadDelay $ 60 * 1000000+ putFile filePath uploadName contentMD5 (noOfRetries + 1)++putFile' :: FilePath -> T.Text -> Maybe B.ByteString -> IO ()+putFile' filePath uploadName contentMD5 = do+ + -- Get S3 config+ cfg <- getS3Config++ -- Create an IORef to store the response Metadata (so it is also available in case of an error).+ metadataRef <- newIORef mempty+ + -- TODO: change to read the file lazy and upload using RequestBodyLBS ...or maybe no, we probably don't gain anything from doing this lazy+ --hndl <- openBinaryFile path ReadMode+ --fileContents <- LB.hGetContents hndl+ --Aws.simpleAwsRef cfg metadataRef $ S3.putObject uploadName getS3BucketName (RequestBodyLBS $ fileContents)+ fileContents <- B.readFile filePath++ -- Get bucket name+ bucketName <- getS3BucketName+ + -- Check if we should use reduced redundancy+ useReducedRedundancy <- getUseS3ReducedRedundancy+ + -- Replace space with underscore in the upload name (S3 does not handle blanks in object names). Doing this is safe since the whole original path is stored in the meta file.+ logDebug ("putFile: will upload file " ++ filePath)+ _ <- Aws.simpleAwsRef cfg metadataRef S3.PutObject { S3.poObjectName = T.replace " " "_" uploadName + , S3.poBucket = bucketName+ , S3.poContentType = Nothing+ , S3.poCacheControl = Nothing+ , S3.poContentDisposition = Nothing+ , S3.poContentEncoding = Nothing+ , S3.poContentMD5 = contentMD5+ , S3.poExpires = Nothing+ , S3.poAcl = Nothing+ , S3.poStorageClass = useReducedRedundancy+ , S3.poRequestBody = RequestBodyBS fileContents + , S3.poMetadata = []+ }+ logDebug "putFile: upload done"++ -- If lazy upload, close the handle+ --logDebug "putFile: close file handle"+ --hClose hndl+ + -- Log the response metadata.+ --ioResponseMetaData <- readIORef metadataRef+ --logDebug $ "putFile: response metadata: " ++ (show ioResponseMetaData)+ readIORef metadataRef >>= logDebug . ("putFile: response metadata: " ++) . show++{-+{-| Deprecated -}+getBkrObjectsOld :: IO [BkrMeta]+getBkrObjectsOld = do++ -- Get AWS credentials+ cfg <- getS3Config+ + -- Create an IORef to store the response Metadata (so it is also available in case of an error).+ metadataRef <- newIORef mempty+ + -- Get bucket info with simpleAwsRef. S3.getBucket returns a GetBucketResponse object.+ bucketName <- getS3BucketName+ s3BkrBucket <- Aws.simpleAwsRef cfg metadataRef $ S3.getBucket bucketName+ --print $ show bucket+ --print $ show $ S3.gbrContents bucket+ + -- Print the response metadata.+ --print =<< readIORef metadataRef++ -- Get bucket contents with gbrContents. gbrContents gets [ObjectInfo]+ let bkrBucketContents = S3.gbrContents s3BkrBucket+ --print $ show $ length bkrBucketContents+ --print $ show contents+ --print $ show $ S3.objectKey $ contents !! 0+ + -- Get object keys (the bkr object filenames)+ let objectKeys = map S3.objectKey bkrBucketContents+ --let t0 = Prelude.head t+ --print t0+ --let t1 = Prelude.last $ T.split (=='.') t0+ --print t1+ + -- Filter the object keys for Bkr meta (.bkrm) objects (files)+ --let bkrObjectFiles = filter (\x -> hasBkrExtension x) objectKeys+ --print "bkrObjectFiles: "+ --print bkrObjectFiles+ --print $ show $ length bkrObjectFiles+ + bkrObjects <- getBkrObject objectKeys+ return bkrObjects+-}+{-+{-| Deprecated. Filter function for filtering .bkrm objects (files). |-}+hasBkrExtension :: T.Text -> Bool+hasBkrExtension t = do+ if (Prelude.last $ T.split (=='.') t) == "bkrm"+ then True+ else False+-}++{-+{-| A small function to save the object's data into a file handle. |-}+saveObject :: IO Handle -> Aws.HTTPResponseConsumer ()+--saveObject hndl status headers source = source $$ sinkIOHandle hndl+saveObject hndl _ _ source = source $$ sinkIOHandle hndl+-}++{-+{-| Takes a list of bkr objects, gets them one by one from S3, parses content creating and returning a list of BkrObject's. This function uses the Knob package for in-memory temporary storage of the downloaded bkr object. |-}+getBkrObject :: [T.Text] -> IO [BkrMeta]+getBkrObject objNames = do++ -- Get S3 config+ cfg <- getS3Config++ -- Create an IORef to store the response Metadata (so it is also available in case of an error).+ metadataRef <- newIORef mempty++ -- Get tmp dir+ --tmpDir <- getTemporaryDirectory++ objects <- forM objNames $ \fileName -> do + -- Get knob object and knob handle (knob is a in-memory virtual file) + knob <- K.newKnob (pack [])+ knobHndl <- K.newFileHandle knob "test.txt" WriteMode+ -- Get the object (.bkrm sfile)+ bucketName <- getS3BucketName+ Aws.simpleAwsRef cfg metadataRef $ S3.getObject bucketName fileName (saveObject $ return knobHndl)+ -- Get data (text) from the knob virtual file + knobDataContents <- K.getContents knob+ -- Close knob+ hClose knobHndl+ -- Get the config pair and get path and checksum from the pair+ pairS <- getConfPairsFromByteString' knobDataContents+ let path_ = fromJust $ lookup "fullpath" pairS+ let checksum_ = fromJust $ lookup "checksum" pairS+ let modificationTime_ = fromJust $ lookup "modificationtime" pairS+ let modificationTimeChecksum_ = fromJust $ lookup "modificationtimechecksum" pairS++ return [BkrMeta path_ checksum_ (show $ getHashForString path_) modificationTime_ modificationTimeChecksum_]+ return (concat objects)+-}+{-+{-| Like getBkrObject but uses a temporary file instead of a virtual file when fetching and reading the bkr object files. |-}+getBkrObject' :: [T.Text] -> IO [BkrMeta]+getBkrObject' fileNames = do++ -- Get S3 config+ cfg <- getS3Config++ -- Create an IORef to store the response Metadata (so it is also available in case of an error).+ metadataRef <- newIORef mempty++ -- Get tmp dir+ tmpDir <- getTemporaryDirectory++ objects <- forM fileNames $ \fileName -> do+ -- Get tmp file path and handle+ (tmpPath, hndl) <- openBinaryTempFileWithDefaultPermissions tmpDir "tmp.bkrm"+ -- Get the object (.bkrm sfile)+ bucketName <- getS3BucketName+ Aws.simpleAwsRef cfg metadataRef $ S3.getObject bucketName fileName (saveObject $ return hndl)+ -- Get a new handle to the tmp file, read it and get the path and checksum+ hndl_ <- openBinaryFile tmpPath ReadMode+ -- Get the conf pair from the tmp file and get path and checksum from the pair+ pairsS <- getConfPairsFromFileS' tmpPath+ let path_ = fromJust $ lookup "fullpath" pairsS+ let checksum_ = fromJust $ lookup "checksum" pairsS+ let modificationTime_ = fromJust $ lookup "modificationtime" pairsS+ let modificationTimeChecksum_ = fromJust $ lookup "modificationtimechecksum" pairsS+ -- Close the handle and delete the tmp file+ hClose hndl_+ removeFile tmpPath++ return [BkrMeta path_ checksum_ (show $ getHashForString path_) modificationTime_ modificationTimeChecksum_]+ return (concat objects)+-}+{-+splitObject :: String -> [T.Text]+splitObject s = T.split (=='.') (T.pack s)+-}