Initial

HLint.hs

@@ -0,0 +1,4 @@
+import "hint" HLint.Default
+import "hint" HLint.Builtin.All
+
+ignore "Use camelCase" = ""

bob.cabal

@@ -0,0 +1,35 @@
+Name:                bob
+Version:             0.1
+Synopsis:            Project Synopsis Here
+Description:         Project Description Here
+License:             AllRightsReserved
+Author:              Author
+Maintainer:          maintainer@example.com
+Stability:           Experimental
+Category:            Web
+Build-type:          Simple
+Cabal-version:       >=1.2
+
+Executable bob
+  hs-source-dirs: src
+  main-is: Main.hs
+  ghc-options: -threaded -O2
+
+  other-modules: Manifest
+               , Sync
+               , Types
+
+  Build-depends: aeson
+               , base
+               , bytestring
+               , directory
+               , filepath
+               , lens
+               , text
+               , wreq
+               , unix-compat
+               , connection
+               , data-default
+               , http-conduit
+               , network-uri
+               , cryptohash

src/Main.hs

@@ -0,0 +1,15 @@
+
+module Main where
+
+import           System.Console.GetOpt
+import           System.Environment
+
+import           Manifest
+import           Sync
+import           Types
+
+main :: IO ()
+main = do
+  options <- getArgs >>= bob_options
+  handle_manifest options
+  handle_sync options

src/Manifest.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Manifest (handle_manifest) where
+
+import           Control.Monad
+import           Data.Aeson
+import qualified Data.ByteString.Char8      as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import           System.Directory
+import           System.FilePath
+
+import           Types
+
+
+handle_manifest :: BOptions -> IO ()
+handle_manifest opts = do
+  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
+     let the_filepath = bf_filepath bf
+     names <- getDirectoryContents the_filepath
+     let names' = filter (`notElem` [".", ".."]) names
+     paths <- forM names' $ \name -> do
+       let path = the_filepath </> name
+       perms <- getPermissions path
+       is_directory <- doesDirectoryExist path
+       if is_directory
+         then walk_directory $ BFilePath path Nothing False
+         else do
+         h <- hash_file path
+         return [BFilePath path (Just h) (executable perms)]
+     return (concat paths)

src/Sync.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Sync (handle_sync) where
+
+import           Control.Lens               hiding ((.=))
+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.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 }
+ where
+   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 " "
+ where
+   sbase :: BOptions -> String
+   sbase opts = fromMaybe "out" (opt_sync_base opts)
+
+handle_file :: FilePath -> FilePath -> BFilePath -> IO ()
+handle_file outd destination (BFilePath file fhash exec) = do
+  let outdir = combine outd (takeDirectory file)
+      localfile = destination </> normalise file
+  de <- doesFileExist localfile
+  case de of
+    True -> check_hash fhash file outdir localfile
+    False -> download_file file outdir localfile
+ where
+   download_file :: FilePath -> FilePath -> FilePath -> IO ()
+   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 "*"
+
+   check_hash :: (Maybe String) -> FilePath -> FilePath -> FilePath -> IO ()
+   check_hash Nothing _ _ _ = putStr "*"
+   check_hash (Just fhash) file outdir localfile = do
+     h <- hash_file localfile
+     case h == fhash of
+       True -> putStr "-"
+       False -> download_file file outdir localfile
+
+
+
+handle_sync :: BOptions -> IO ()
+handle_sync opts =
+  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
+        200 ->
+          case decode (request ^. responseBody) of
+            Nothing -> error "Found manifest, but can't decode it."
+            Just mn -> rebuild_filesystem opts mn dest_directory
+        b -> error $ "Response code: " ++ show b

src/Types.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Types where
+
+import           Control.Monad              (mzero)
+import           Crypto.Hash
+import qualified Crypto.Hash.SHA1           as SH
+import           Data.Aeson
+import qualified Data.ByteString.Char8      as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.Text                  as T
+import           System.Console.GetOpt
+import           System.FilePath
+
+
+data BFilePath = BFilePath { bf_filepath   :: FilePath
+                           , bf_hash       :: Maybe String
+                           , bf_executable :: Bool }
+                 deriving (Show)
+
+
+data Manifest = Manifest { mf_files   :: [BFilePath]
+                         , mf_version :: T.Text }
+              deriving (Show)
+
+
+
+instance ToJSON BFilePath where
+  toJSON (BFilePath fp h e) = object [ "filepath" .= fp
+                                     , "hash" .= h
+                                     , "executable" .= e ]
+
+instance FromJSON BFilePath where
+  parseJSON (Object o) =
+    BFilePath <$> o .: "filepath"
+              <*> o .: "hash"
+              <*> o .: "executable"
+  parseJSON _ = mzero
+
+instance ToJSON Manifest where
+  toJSON (Manifest f v) = object [ "files" .= f
+                                 , "version" .= v ]
+
+instance FromJSON Manifest where
+  parseJSON (Object o) =
+    Manifest <$> o .: "files"
+             <*> o .: "version"
+  parseJSON _ = mzero
+
+
+
+data BOptions = BOptions { opt_verbose   :: Bool
+                         , opt_generate  :: Maybe FilePath
+                         , opt_gen_base  :: Maybe FilePath
+                         , opt_sync      :: Maybe String
+                         , opt_sync_base :: Maybe FilePath }
+                deriving (Show)
+
+default_options :: BOptions
+default_options = BOptions False 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 ['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 }
+
+bob_options :: [String] -> IO BOptions
+bob_options argv =
+  case getOpt Permute cmd_options argv of
+    (g,_,[]) -> return $ foldl (flip id) default_options g
+    (_,_,err) -> ioError (userError (concat err ++ usageInfo header cmd_options))
+ where
+   header :: String
+   header = "Usage: bob [OPTION..] files..."
+
+hash_file :: FilePath -> IO String
+hash_file fp = do
+  contents <- BSL.readFile fp
+  return $ BS.unpack $ digestToHexByteString $ sha1 contents
+ where
+   sha1 :: BSL.ByteString -> Digest SHA1
+   sha1 = hashlazy

stack.yaml

@@ -0,0 +1,32 @@
+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
+
+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
+resolver: lts-3.20
+
+# Local packages, usually specified by relative directory name
+packages:
+- '.'
+
+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: >= 0.1.4.0
+
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]