Write blockCopy's first version

Wow it's like being a proud parent. This software is written
for exactly one purpose: to mount an encrypted volume on Google Drive
with reasonably good performance. It's based around the idea that the
fastest thing for Google Drive is reading and writing whole files, so
we break a file up into blocks and transfer only whole blocks. It works,
but it's still really slow.

1 files changed, 280 insertions, 0 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
new file mode 100644
index 0000000..c90888b
--- /dev/null
+++ b/src/Lib.hs
@@ -0,0 +1,280 @@
+{-
+ - Copyright 2018 Raymond Hogenson
+
+ - This file is part of BlockCopy
+
+ - BlockCopy is free software: you can redistribute it and/or modify
+ - it under the terms of the GNU General Public License as published by
+ - the Free Software Foundation, either version 3 of the License, or
+ - (at your option) any later version.
+
+ - BlockCopy is distributed in the hope that it will be useful,
+ - but WITHOUT ANY WARRANTY; without even the implied warranty of
+ - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ - GNU General Public License for more details.
+
+ - You should have received a copy of the GNU General Public License
+ - along with BlockCopy.  If not, see <https://www.gnu.org/licenses/>.
+ -}
+
+module Lib (blockCopyMain) where
+
+import qualified Foreign.C.Error as E
+import qualified System.Fuse as F
+import qualified System.Posix.Types as T
+import qualified Data.ByteString as B
+import qualified System.FilePath as FP
+import qualified Data.IORef as IOR
+import qualified Data.Map as M
+import qualified Control.Concurrent.ReadWriteLock as RWL
+import qualified System.Posix.User as U
+import qualified Control.Exception as Ex
+import qualified System.Posix.Time as Ti
+import qualified Data.ByteString.Char8 as C8
+import qualified System.Environment as En
+import qualified System.Directory as D
+import qualified Control.Concurrent.ParallelIO as P
+
+newtype Handle = Handle ()
+
+data BlockCopy =
+  BlockCopy (IOR.IORef (M.Map Int RWL.RWLock)) FilePath
+
+statsMessage :: BlockCopy -> IO B.ByteString
+statsMessage (BlockCopy _ store) = do
+  let stats = "store: " ++ store ++ "\n"
+  return $ C8.pack stats
+
+mkFuseGetFileStat :: BlockCopy -> FilePath -> IO (Either E.Errno F.FileStat)
+mkFuseGetFileStat b s = do
+  ln ("fileStat on " ++ s)
+  userID <- U.getEffectiveUserID
+  groupID <- U.getEffectiveGroupID
+  statsSize <- fmap (fromIntegral . B.length) $ statsMessage b
+  case s of
+    "/" -> return $ Right $ F.FileStat F.Directory 0o777 1 userID groupID 0 0 0 0 0 0
+    "/disk" -> return $ Right $ F.FileStat F.RegularFile 0o666 1 userID groupID 0 maxBound 0 0 0 0
+    "/stats" -> return $ Right $ F.FileStat F.RegularFile 0o666 1 userID groupID 0 statsSize 0 0 0 0
+    _ -> return $ Left $ E.eNOENT
+
+fuseReadSymbolicLink :: FilePath -> IO (Either E.Errno FilePath)
+fuseReadSymbolicLink _ = return $ Left $ E.eNOENT
+
+fuseCreateDevice :: FilePath -> F.EntryType -> T.FileMode -> T.DeviceID -> IO E.Errno
+fuseCreateDevice _ _ _ _ = do
+  ln "createDevice"
+  return E.eNOTSUP
+
+fuseCreateDirectory :: FilePath -> T.FileMode -> IO E.Errno
+fuseCreateDirectory _ _ = do
+  ln "createDirectory"
+  return E.eNOTSUP
+
+fuseRemoveLink :: FilePath -> IO E.Errno
+fuseRemoveLink _ = do
+  ln "removeLink"
+  return E.eNOTSUP
+
+fuseRemoveDirectory :: FilePath -> IO E.Errno
+fuseRemoveDirectory _ = return E.eNOTSUP
+
+fuseCreateSymbolicLink :: FilePath -> FilePath -> IO E.Errno
+fuseCreateSymbolicLink _ _ = return E.eNOTSUP
+
+fuseRename :: FilePath -> FilePath -> IO E.Errno
+fuseRename _ _ = do
+  ln "rename"
+  return E.eNOTSUP
+
+fuseCreateLink :: FilePath -> FilePath -> IO E.Errno
+fuseCreateLink _ _ = return E.eNOTSUP
+
+fuseSetFileMode :: FilePath -> T.FileMode -> IO E.Errno
+fuseSetFileMode _ _ = return E.eNOTSUP
+
+fuseSetOwnerAndGroup :: FilePath -> T.UserID -> T.GroupID -> IO E.Errno
+fuseSetOwnerAndGroup _ _ _ = return E.eNOTSUP
+
+mkFuseSetFileSize :: BlockCopy -> FilePath -> T.FileOffset -> IO E.Errno
+mkFuseSetFileSize _ _ _ = return E.eOK
+
+fuseSetFileTimes :: FilePath -> T.EpochTime -> T.EpochTime -> IO E.Errno
+fuseSetFileTimes _ _ _ = return E.eNOTSUP
+
+fuseOpen :: FilePath -> F.OpenMode -> F.OpenFileFlags
+  -> IO (Either E.Errno Handle)
+fuseOpen "/disk" _ _ = do
+  ln "open /disk"
+  return $ Right $ Handle ()
+fuseOpen "/stats" _ _ = return $ Right $ Handle ()
+fuseOpen _ _ _ = return $ Left $ E.eNOENT
+
+blockSize :: T.ByteCount
+blockSize = 4096
+
+blockPath :: BlockCopy -> Int -> FilePath
+blockPath (BlockCopy _ store) block = store FP.</> show block
+
+getLock :: BlockCopy -> Int -> IO RWL.RWLock
+getLock (BlockCopy locks _) block = do
+  newLock <- RWL.new
+  IOR.atomicModifyIORef'
+    locks (\m ->
+      case M.lookup block m of
+        Nothing -> (M.insert block newLock m, newLock)
+        Just a -> (m, a))
+
+withReadLocks :: BlockCopy -> [Int] -> IO a -> IO a
+withReadLocks b blocks op = do
+  ls <- mapM (getLock b) blocks
+  mapM_ RWL.acquireRead ls
+  x <- op
+  mapM_ RWL.releaseRead ls
+  return x
+
+withWriteLocks :: BlockCopy -> [Int] -> IO a -> IO a
+withWriteLocks b blocks op = do
+  ls <- mapM (getLock b) blocks
+  mapM_ RWL.acquireWrite ls
+  x <- op
+  mapM_ RWL.releaseWrite ls
+  return x
+
+readBlock :: BlockCopy -> Int -> IO B.ByteString
+readBlock b block = do
+  x <- Ex.try
+    $ B.readFile
+    $ blockPath b block :: IO (Either Ex.SomeException B.ByteString)
+  case x of
+    Left e -> do
+      ln $ show e ++ ": read of non-existent block " ++ show block
+      return $ B.replicate (fromIntegral blockSize) 0
+    Right s -> return $ B.take (fromIntegral blockSize) s
+
+mkFuseRead :: BlockCopy -> FilePath -> Handle -> T.ByteCount -> T.FileOffset
+  -> IO (Either E.Errno B.ByteString)
+mkFuseRead store "/disk" _ count offset = do
+  ln $ "Read /disk count=" ++ show count ++ " offset=" ++ show offset
+  let block = fromIntegral offset `div` fromIntegral blockSize
+  let lastBlock = fromIntegral (offset + fromIntegral count - 1)
+        `div` fromIntegral blockSize
+  let blockOffset = offset `mod` fromIntegral blockSize
+  fmap
+    (Right . B.take (fromIntegral count) . B.drop (fromIntegral blockOffset))
+      $ withReadLocks store [block..lastBlock] $ fmap (B.intercalate B.empty)
+      $ P.parallel $ map (readBlock store) [block..lastBlock]
+mkFuseRead b "/stats" _ count offset = do
+  bs <- statsMessage b
+  return $ Right $ B.take (fromIntegral count) $ B.drop (fromIntegral offset) bs
+mkFuseRead _ _ _ _ _ = return $ Left E.eNOENT
+
+ln :: String -> IO ()
+ln s = do
+  time <- Ti.epochTime
+  _ <- Ex.try
+    $ appendFile "/home/ray/log"
+    $ "[" ++ show time ++ "] " ++ s ++ "\n" :: IO (Either Ex.SomeException ())
+  return ()
+
+blit :: B.ByteString -> Int -> B.ByteString -> B.ByteString
+blit a i x = B.intercalate B.empty [B.take i a, B.take (B.length a - i) x, B.drop (B.length x + i) a]
+
+mkFuseWrite :: BlockCopy -> FilePath -> Handle -> B.ByteString -> T.FileOffset
+  -> IO (Either E.Errno T.ByteCount)
+mkFuseWrite store "/disk" _ string offset = do
+  ln $ "Write to /disk of size " ++ show (B.length string)
+  let block = fromIntegral offset `div` fromIntegral blockSize
+  let lastBlock = fromIntegral (offset + fromIntegral (B.length string) - 1)
+        `div` fromIntegral blockSize
+  let blockOffset = offset `mod` fromIntegral blockSize
+  withWriteLocks store [block..lastBlock] $ P.parallel_
+    $ map (\bl ->
+        let mySuffix =
+              B.drop
+                ((bl - 1) * fromIntegral blockSize + fromIntegral blockOffset)
+                string
+        in if bl == block && blockOffset /= 0
+          then do
+            currentContents <- readBlock store bl
+            B.writeFile (blockPath store bl)
+              (blit currentContents (fromIntegral blockOffset) string)
+          else if bl == lastBlock && B.length mySuffix < fromIntegral blockSize
+            then do
+              currentContents <- readBlock store bl
+              B.writeFile (blockPath store bl)
+                (blit currentContents 0 mySuffix)
+            else do
+              B.writeFile (blockPath store bl)
+                (B.take (fromIntegral blockSize) mySuffix))
+        [block..lastBlock]
+  return $ Right $ fromIntegral $ B.length string
+mkFuseWrite _ _ _ _ _ = return $ Left E.eNOENT
+
+fuseGetFileSystemStats :: String -> IO (Either E.Errno F.FileSystemStats)
+fuseGetFileSystemStats _ = return $ Right $ F.FileSystemStats 512 0 0 0 1 0 255
+
+fuseFlush :: FilePath -> Handle -> IO E.Errno
+fuseFlush _ _ = return E.eOK
+
+fuseRelease :: FilePath -> Handle -> IO ()
+fuseRelease _ _ = return ()
+
+fuseSynchronizeFile :: FilePath -> F.SyncType -> IO E.Errno
+fuseSynchronizeFile _ _ = return E.eOK
+
+fuseOpenDirectory :: FilePath -> IO E.Errno
+fuseOpenDirectory _ = return E.eOK
+
+mkFuseReadDirectory :: BlockCopy -> FilePath
+  -> IO (Either E.Errno [(FilePath, F.FileStat)])
+mkFuseReadDirectory b _ = do
+  s <- mkFuseGetFileStat b "/disk"
+  k <- mkFuseGetFileStat b "/stats"
+  case (s, k) of
+    (Right a, Right g) -> return $ Right [("disk", a), ("stats", g)]
+    (Left e, _) -> return $ Left e
+    (_, Left e) -> return $ Left e
+
+fuseReleaseDirectory :: FilePath -> IO E.Errno
+fuseReleaseDirectory _ = return E.eOK
+
+fuseSynchronizeDirectory :: FilePath -> F.SyncType -> IO E.Errno
+fuseSynchronizeDirectory _ _ = return E.eOK
+
+fuseAccess :: FilePath -> Int -> IO E.Errno
+fuseAccess _ _ = return E.eOK
+
+fuseInit :: IO ()
+fuseInit = ln "init"
+
+fuseDestroy :: IO ()
+fuseDestroy = ln "destroy"
+
+handler :: Ex.SomeException -> IO E.Errno
+handler e = do
+  ln $ "ERROR: " ++ show e
+  return E.eFAULT
+
+blockCopyMain :: IO ()
+blockCopyMain = do
+  locks <- IOR.newIORef M.empty
+  prog <- En.getProgName
+  args <- En.getArgs
+  case args of
+    [] -> putStrLn "please store"
+    (store : mArgs) -> do
+      ln "main"
+      trueStore <- D.canonicalizePath store
+      let bs = BlockCopy locks trueStore
+      F.fuseRun prog mArgs
+        (F.FuseOperations (mkFuseGetFileStat bs) fuseReadSymbolicLink
+          fuseCreateDevice
+          fuseCreateDirectory fuseRemoveLink
+          fuseRemoveDirectory fuseCreateSymbolicLink fuseRename fuseCreateLink
+          fuseSetFileMode fuseSetOwnerAndGroup
+          (mkFuseSetFileSize bs) fuseSetFileTimes fuseOpen (mkFuseRead bs)
+          (mkFuseWrite bs) fuseGetFileSystemStats
+          fuseFlush fuseRelease fuseSynchronizeFile fuseOpenDirectory
+          (mkFuseReadDirectory bs) fuseReleaseDirectory
+          fuseSynchronizeDirectory fuseAccess fuseInit fuseDestroy)
+        handler