diff --git a/bob.cabal b/bob.cabal index 9f9ecdd..e0e63d9 100644 --- a/bob.cabal +++ b/bob.cabal @@ -33,3 +33,4 @@ Executable bob , http-conduit , network-uri , cryptohash + , mtl \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 61d7c22..c4fc2b6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,7 @@ module Main where +import Control.Monad.State import System.Console.GetOpt import System.Environment @@ -11,5 +12,5 @@ import Types main :: IO () main = do options <- getArgs >>= bob_options - handle_manifest options - handle_sync options + runStateT (handle_manifest >> handle_sync) options + return () diff --git a/src/Manifest.hs b/src/Manifest.hs index 33a6783..ff798f4 100644 --- a/src/Manifest.hs +++ b/src/Manifest.hs @@ -3,6 +3,7 @@ module Manifest (handle_manifest) where import Control.Monad +import Control.Monad.State import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL @@ -12,17 +13,19 @@ import System.FilePath import Types -handle_manifest :: BOptions -> IO () -handle_manifest opts = do +handle_manifest :: BState () +handle_manifest = do + opts <- get case (,) <$> (opt_generate opts) <*> (opt_gen_base opts) of Nothing -> return () Just (gen,base) -> do - putStrLn "Generating manifest from current directory." - files <- walk_directory $ BFilePath base Nothing False - BSL.writeFile gen $ encode $ Manifest files "0.0.1" - where - walk_directory :: BFilePath -> IO [BFilePath] - walk_directory bf = do + lift $ putStrLn "Generating manifest from current directory." + files <- lift $ walk_directory $ BFilePath base Nothing False + lift $ BSL.writeFile gen $ encode $ Manifest files "0.0.1" + return () + +walk_directory :: BFilePath -> IO [BFilePath] +walk_directory bf = do let the_filepath = bf_filepath bf names <- getDirectoryContents the_filepath let names' = filter (`notElem` [".", ".."]) names diff --git a/src/Sync.hs b/src/Sync.hs index 432bebd..9dbd505 100644 --- a/src/Sync.hs +++ b/src/Sync.hs @@ -3,6 +3,8 @@ module Sync (handle_sync) where import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.State import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BS import Data.Default @@ -10,7 +12,7 @@ import Data.Maybe (fromMaybe) import Network.Connection import Network.HTTP.Conduit hiding (responseBody, responseStatus) -import Network.Wreq +import qualified Network.Wreq as W import qualified Network.Wreq.Types as WT import System.Directory import System.FilePath @@ -18,72 +20,82 @@ import System.IO import Types -request_options :: IO WT.Options -request_options = do - lx <- newManager $ mkManagerSettings tls_settings Nothing - return $ defaults { WT.manager = Right lx } + +get_file :: FilePath -> BState BS.ByteString +get_file fp = do + ropt <- lift request_options + conf <- get + case opt_url_base conf of + Nothing -> error "Need to supply the -u option." + Just ubase -> do + let filename = ubase ++ fp + rq <- lift $ W.getWith ropt filename + return $ rq ^. W.responseBody where + request_options :: IO WT.Options + request_options = do + lx <- newManager $ mkManagerSettings tls_settings Nothing + return $ W.defaults { WT.manager = Right lx } tls_settings :: TLSSettings tls_settings = def { settingDisableCertificateValidation = True } -get_file :: FilePath -> IO BS.ByteString -get_file fp = do - ropt <- request_options - let filename = "https://tools.ivy.io/" ++ fp - rq <- getWith ropt filename - return $ rq ^. responseBody - -rebuild_filesystem :: BOptions -> Manifest -> FilePath -> IO () -rebuild_filesystem opts manifest destination = do - hSetBuffering stdout NoBuffering - putStrLn "Syncing." - _ <- mapM (handle_file (sbase opts) destination) (mf_files manifest) - putStrLn " " +rebuild_filesystem :: Manifest -> FilePath -> BState () +rebuild_filesystem manifest destination = do + lift $ do + hSetBuffering stdout NoBuffering + putStrLn "Syncing." + conf <- get + _ <- mapM (handle_file (sbase conf) destination) (mf_files manifest) + lift $ putStrLn " " where sbase :: BOptions -> String sbase opts = fromMaybe "out" (opt_sync_base opts) -handle_file :: FilePath -> FilePath -> BFilePath -> IO () +handle_file :: FilePath -> FilePath -> BFilePath -> BState () handle_file outd destination (BFilePath file fhash exec) = do let outdir = combine outd (takeDirectory file) localfile = destination normalise file - de <- doesFileExist localfile + de <- lift $ doesFileExist localfile case de of - True -> check_hash fhash file outdir localfile - False -> download_file file outdir localfile + True -> do + check_hash fhash file outdir localfile + return () + False -> do + download_file file outdir localfile + return () where - download_file :: FilePath -> FilePath -> FilePath -> IO () + download_file :: FilePath -> FilePath -> FilePath -> BState () download_file file outdir localfile = do - contents <- get_file file - createDirectoryIfMissing True outdir - BS.writeFile localfile contents - case exec of - False -> putStr "+" - True -> do - lx <- getPermissions localfile - setPermissions localfile (setOwnerExecutable True lx) - putStr "*" + contents <- get_file file + lift $ createDirectoryIfMissing True outdir + lift $ BS.writeFile localfile contents + case exec of + False -> lift $ putStr "+" + True -> do + lx <- lift $ getPermissions localfile + lift $ setPermissions localfile (setOwnerExecutable True lx) + lift $ putStr "*" - check_hash :: (Maybe String) -> FilePath -> FilePath -> FilePath -> IO () - check_hash Nothing _ _ _ = putStr "*" + check_hash :: (Maybe String) -> FilePath -> FilePath -> FilePath -> BState () + check_hash Nothing _ _ _ = lift $ putStr "*" check_hash (Just fhash) file outdir localfile = do - h <- hash_file localfile + h <- lift $ hash_file localfile case h == fhash of - True -> putStr "-" + True -> lift $ putStr "-" False -> download_file file outdir localfile - - -handle_sync :: BOptions -> IO () -handle_sync opts = +handle_sync :: BState () +handle_sync = do + opts <- get case (,) <$> (opt_sync opts) <*> (opt_sync_base opts) of Nothing -> return () Just (remote_url,dest_directory) -> do - putStrLn "Fetching manifest." - request <- get remote_url - case request ^. responseStatus ^. statusCode of + lift $ putStrLn "Fetching manifest." + request <- lift $ W.get remote_url + case request ^. W.responseStatus ^. W.statusCode of 200 -> - case decode (request ^. responseBody) of + case decode (request ^. W.responseBody) of Nothing -> error "Found manifest, but can't decode it." - Just mn -> rebuild_filesystem opts mn dest_directory + Just mn -> rebuild_filesystem mn dest_directory b -> error $ "Response code: " ++ show b + diff --git a/src/Types.hs b/src/Types.hs index 54df0eb..d890dca 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -2,7 +2,8 @@ module Types where -import Control.Monad (mzero) +import Control.Monad (ap, liftM, mzero) +import Control.Monad.State import Crypto.Hash import qualified Crypto.Hash.SHA1 as SH import Data.Aeson @@ -12,6 +13,7 @@ import qualified Data.Text as T import System.Console.GetOpt import System.FilePath +type BState a = StateT BOptions IO a data BFilePath = BFilePath { bf_filepath :: FilePath , bf_hash :: Maybe String @@ -53,23 +55,26 @@ data BOptions = BOptions { opt_verbose :: Bool , opt_generate :: Maybe FilePath , opt_gen_base :: Maybe FilePath , opt_sync :: Maybe String - , opt_sync_base :: Maybe FilePath } + , opt_sync_base :: Maybe FilePath + , opt_url_base :: Maybe String } deriving (Show) default_options :: BOptions -default_options = BOptions False Nothing Nothing Nothing Nothing +default_options = BOptions False Nothing Nothing Nothing Nothing Nothing cmd_options :: [OptDescr (BOptions -> BOptions)] cmd_options = [ Option ['g'] ["generate"] (ReqArg gen_opt "FILE") "generate a manifest" , Option ['b'] ["gen-base"] (ReqArg gbase_opt "DIR") "base directory for manifest" , Option ['s'] ["sync"] (ReqArg sync_opt "URL") "synchronize the given url" + , Option ['u'] ["url"] (ReqArg url_base_opt "URL") "base url for file requests" , Option ['o'] ["sync-base"] (ReqArg sync_base_opt "DIR") "directory to synchronize to" ] where gen_opt f o = o { opt_generate = Just f } gbase_opt f o = o { opt_gen_base = Just f } sync_opt f o = o { opt_sync = Just f } sync_base_opt f o = o { opt_sync_base = Just f } + url_base_opt f o = o { opt_url_base = Just f } bob_options :: [String] -> IO BOptions bob_options argv =