module Network.Google.Storage.Sync (
RegexExclusion
, sync
) where
import Control.Exception (SomeException, finally, handle)
import Control.Monad (filterM, liftM, when)
import Crypto.GnuPG (Recipient)
import Crypto.MD5 (MD5Info, md5Base64, md5Empty)
import qualified Data.ByteString.Lazy as LBS (ByteString, readFile)
import qualified Data.Digest.Pure.MD5 as MD5 (md5)
import Data.List ((\\), sort)
import Data.Maybe (fromJust, mapMaybe)
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.Format (parseTime)
import Network.Google (AccessToken, ProjectId, toAccessToken)
import Network.Google.OAuth2 (OAuth2Client(..), OAuth2Tokens(..), refreshTokens, validateTokens)
import Network.Google.Storage (BucketName, KeyName, MIMEType, StorageAcl, deleteObjectUsingManager, getBucketUsingManager, putObjectUsingManager)
import Network.Google.Storage.Encrypted (putEncryptedObject, putEncryptedObjectUsingManager)
import Network.HTTP.Conduit (closeManager, def, newManager)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath (pathSeparator)
import System.IO (hFlush, stdout)
import System.Locale (defaultTimeLocale)
import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
import Text.Regex.Posix ((=~))
import Text.XML.Light (Element, QName(qName), filterChildrenName, filterChildName, ppTopElement, strContent)
type RegexExclusion = String
sync ::
ProjectId
-> StorageAcl
-> BucketName
-> OAuth2Client
-> OAuth2Tokens
-> FilePath
-> [Recipient]
-> [RegexExclusion]
-> Bool
-> Bool
-> IO ()
sync projectId acl bucket client tokens directory recipients exclusions md5sums purge =
do
putStrLn $ "DIRECTORY " ++ directory
putStrLn $ "PROJECT " ++ projectId
putStrLn $ "BUCKET " ++ bucket
putStrLn $ "ACCESS " ++ show acl
putStr "LOCAL "
hFlush stdout
let
byETag = null recipients && md5sums
local <- liftM sort $ walkDirectories byETag directory
print $ length local
putStr "EXCLUDED "
hFlush stdout
let
local' = filter (makeExcluder exclusions) local
print $ length local length local'
manager <- newManager def
finally
(
sync'
(getBucketUsingManager manager projectId bucket)
((if null recipients then putObjectUsingManager manager else putEncryptedObjectUsingManager manager recipients) projectId acl bucket)
(deleteObjectUsingManager manager projectId bucket)
client tokens directory
byETag
local'
md5sums
purge
)(
closeManager manager
)
type Lister =
AccessToken
-> IO Element
type Putter =
KeyName
-> Maybe MIMEType
-> LBS.ByteString
-> Maybe MD5Info
-> AccessToken
-> IO [(String, String)]
type Deleter =
KeyName
-> AccessToken
-> IO [(String, String)]
type Excluder =
ObjectMetadata
-> Bool
type TokenClock = (UTCTime, OAuth2Tokens)
checkExpiration ::
OAuth2Client
-> TokenClock
-> IO TokenClock
checkExpiration client (expirationTime, tokens) =
do
now <- getCurrentTime
if now > expirationTime
then
do
tokens' <- refreshTokens client tokens
start <- getCurrentTime
let
expirationTime' = addUTCTime (fromRational (expiresIn tokens') 60) start
putStrLn $ "REFRESH " ++ show expirationTime'
return (expirationTime', tokens')
else
return (expirationTime, tokens)
makeExcluder ::
[RegexExclusion]
-> Excluder
makeExcluder exclusions (ObjectMetadata candidate _ _ _) =
let
match :: String -> Bool
match exclusion = candidate =~ exclusion
in
not $ any match exclusions
sync' ::
Lister
-> Putter
-> Deleter
-> OAuth2Client
-> OAuth2Tokens
-> FilePath
-> Bool
-> [ObjectMetadata]
-> Bool
-> Bool
-> IO ()
sync' lister putter deleter client tokens directory byETag local md5sums purge =
do
now <- getCurrentTime
tokenClock@(_, tokens') <- checkExpiration client (addUTCTime (60) now, tokens)
putStr "REMOTE "
hFlush stdout
remote' <- lister $ toAccessToken $ accessToken tokens'
let
remote = sort $ parseMetadata remote'
print $ length remote
let
tolerance = 300
sameKey :: ObjectMetadata -> ObjectMetadata -> Bool
sameKey (ObjectMetadata key _ _ _) (ObjectMetadata key' _ _ _) = key == key'
sameETag :: ObjectMetadata -> ObjectMetadata -> Bool
sameETag (ObjectMetadata key eTag _ _) (ObjectMetadata key' eTag' _ _) = key == key' && fst eTag == fst eTag'
earlierTime :: ObjectMetadata -> ObjectMetadata -> Bool
earlierTime (ObjectMetadata key _ _ time) (ObjectMetadata key' _ _ time') = key == key' && addUTCTime tolerance time < time'
putStr "PUTS "
hFlush stdout
let
changedObjects = deleteFirstsBy' (if byETag then sameETag else earlierTime) local remote
print $ length changedObjects
putStr "DELETES "
hFlush stdout
let
deletedObjects = deleteFirstsBy' sameKey remote local
print $ length deletedObjects
tokenClock' <- walkPutter client tokenClock directory putter changedObjects
tokenClock'' <- if purge
then
walkDeleter client tokenClock' deleter deletedObjects
else
return tokenClock'
when md5sums $
writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local
deleteFirstsBy' :: Ord a =>
(a -> a -> Bool)
-> [a]
-> [a]
-> [a]
deleteFirstsBy' _ [] _ = []
deleteFirstsBy' _ xx [] = xx
deleteFirstsBy' equal xx@(x : xs) yy@(y : ys)
| equal x y = deleteFirstsBy' equal xs ys
| x > y = deleteFirstsBy' equal xx ys
| otherwise = x : deleteFirstsBy' equal xs yy
walkPutter ::
OAuth2Client
-> TokenClock
-> FilePath
-> Putter
-> [ObjectMetadata]
-> IO TokenClock
walkPutter _ tokenClock _ _ [] = return tokenClock
walkPutter client tokenClock directory putter (x : xs) =
do
let
key' = key x
tokenClock'@(_, tokens') <- checkExpiration client tokenClock
putStrLn $ "PUT " ++ key'
handle
handler
(
do
let
eTag' x = if eTag x == md5Empty then Nothing else Just $ eTag x
bytes <- LBS.readFile $ directory ++ [pathSeparator] ++ key'
putter key' Nothing bytes (eTag' x) (toAccessToken $ accessToken tokens')
return ()
)
walkPutter client tokenClock' directory putter xs
walkDeleter ::
OAuth2Client
-> TokenClock
-> Deleter
-> [ObjectMetadata]
-> IO TokenClock
walkDeleter _ tokenClock _ [] = return tokenClock
walkDeleter client tokenClock deleter (x : xs) =
do
let
key' = key x
tokenClock'@(_, tokens') <- checkExpiration client tokenClock
putStrLn $ "DELETE " ++ key'
handle
handler
(
do
deleter key' (toAccessToken $ accessToken tokens')
return ()
)
walkDeleter client tokenClock' deleter xs
handler :: SomeException -> IO ()
handler exception = putStrLn $ " FAIL " ++ show exception
data ObjectMetadata = ObjectMetadata
{
key :: String
, eTag :: MD5Info
, size :: Int
, lastModified :: UTCTime
}
deriving (Show)
instance Ord ObjectMetadata where
compare (ObjectMetadata key _ _ _) (ObjectMetadata key' _ _ _) = compare key key'
instance Eq ObjectMetadata where
(ObjectMetadata key _ _ _) == (ObjectMetadata key' _ _ _) = key == key'
parseMetadata ::
Element
-> [ObjectMetadata]
parseMetadata root =
let
makeMetadata :: Element -> Maybe ObjectMetadata
makeMetadata element =
do
let
finder :: String -> Element -> Maybe String
finder name = liftM strContent . filterChildName ((name ==) . qName)
key <- finder "Key" element
eTag <- finder "ETag" element
size <- finder "Size" element
lastModified <- finder "LastModified" element
return $ ObjectMetadata key (tail . init $ eTag, undefined) (read size) (fromJust $ parseTime defaultTimeLocale "%FT%T%QZ" lastModified)
in
mapMaybe makeMetadata $ filterChildrenName (("Contents" ==) . qName) root
walkDirectories ::
Bool
-> FilePath
-> IO [ObjectMetadata]
walkDirectories eTags directory = walkDirectories' eTags (directory ++ [pathSeparator]) [""]
walkDirectories' ::
Bool
-> FilePath
-> [FilePath]
-> IO [ObjectMetadata]
walkDirectories' _ _ [] = return []
walkDirectories' eTags directory (y : ys) =
handle
((
\exception ->
do
putStrLn $ " LIST " ++ y
putStrLn $ " FAIL " ++ show exception
walkDirectories' eTags directory ys
) :: SomeException -> IO [ObjectMetadata])
(
do
let
makeMetadata :: FilePath -> IO ObjectMetadata
makeMetadata file =
do
let
key = tail file
path = directory ++ key
bytes <- LBS.readFile path
status <- getFileStatus path
let
!lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
!size = fromIntegral $ fileSize status
!eTag = if eTags then md5Base64 bytes else md5Empty
return $ ObjectMetadata key eTag size lastTime
files <- liftM (map ((y ++ [pathSeparator]) ++) . ( \\ [".", ".."]))
$ getDirectoryContents (directory ++ y)
y' <- filterM (doesDirectoryExist . (directory ++)) files
x' <- mapM makeMetadata $ files \\ y'
liftM (x' ++) $ walkDirectories' eTags directory (y' ++ ys)
)