Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
A little transformer cleanup.
  • Loading branch information
cmoore committed Jan 13, 2016
1 parent 8d3b358 commit 5642262
Show file tree
Hide file tree
Showing 5 changed files with 80 additions and 58 deletions.
1 change: 1 addition & 0 deletions bob.cabal
Expand Up @@ -33,3 +33,4 @@ Executable bob
, http-conduit
, network-uri
, cryptohash
, mtl
5 changes: 3 additions & 2 deletions src/Main.hs
@@ -1,6 +1,7 @@

module Main where

import Control.Monad.State
import System.Console.GetOpt
import System.Environment

Expand All @@ -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 ()
19 changes: 11 additions & 8 deletions src/Manifest.hs
Expand Up @@ -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
Expand All @@ -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
Expand Down
102 changes: 57 additions & 45 deletions src/Sync.hs
Expand Up @@ -3,87 +3,99 @@
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
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
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

11 changes: 8 additions & 3 deletions src/Types.hs
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down

0 comments on commit 5642262

Please sign in to comment.