Add a bunch of features

We're about to destroy everything

1 files changed, 66 insertions, 18 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index d50e6aa..4f4202e 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -37,6 +37,8 @@ import qualified System.Directory as D
 import qualified Control.Concurrent.ParallelIO as P
 import qualified Data.List as L
 import qualified Data.Maybe as Ma
+import qualified System.Timeout as Tim
+import qualified System.IO.Error as Er
 
 newtype Handle = Handle ()
 
@@ -53,7 +55,7 @@ statsMessage BlockCopy { bStore, bSize, bBlockSize, ..} = do
   return $ C8.pack stats
 
 mkFuseGetFileStat :: BlockCopy -> FilePath -> IO (Either E.Errno F.FileStat)
-mkFuseGetFileStat b@BlockCopy { bSize, .. } s = do
+mkFuseGetFileStat b@BlockCopy { bSize, bBlockSize, .. } s = do
   ln ("fileStat on " ++ s)
   userID <- U.getEffectiveUserID
   groupID <- U.getEffectiveGroupID
@@ -63,7 +65,8 @@ mkFuseGetFileStat b@BlockCopy { bSize, .. } s = do
       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 bSize 0 0 0 0
+        $ F.FileStat F.RegularFile 0o666 1 userID groupID 0 bSize
+          (fromIntegral bSize `div` fromIntegral bBlockSize) 0 0 0
     "/stats" ->
       return $ Right
         $ F.FileStat F.RegularFile 0o666 1 userID groupID 0 statsSize 0 0 0 0
@@ -149,16 +152,59 @@ withWriteLocks b blocks op = do
   mapM_ RWL.releaseWrite ls
   return x
 
+ioTimeout :: Int
+ioTimeout = 30000000
+
+timeoutRead :: BlockCopy -> Int -> IO (Maybe B.ByteString)
+timeoutRead b i = Tim.timeout ioTimeout (B.readFile (blockPath b i)) 
+
+maxRetries :: Int
+maxRetries = 5
+
 readBlock :: BlockCopy -> Int -> IO B.ByteString
 readBlock b@BlockCopy { bBlockSize, .. } 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 bBlockSize) 0
-    Right s -> return $ B.take (fromIntegral bBlockSize) s
+  let go r
+        | r >= maxRetries = Ex.throwIO (userError "Timeout")
+        | otherwise = do
+          x <- Ex.try (timeoutRead b block)
+          case x of
+            Left e
+              | Er.isDoesNotExistError e -> do
+                ln $ show e ++ ": read of non-existent block " ++ show block
+                return $ B.replicate (fromIntegral bBlockSize) 0
+              | otherwise -> Ex.throwIO e
+            Right Nothing -> do
+              ln $ "Timeout reading block " ++ show block ++ ". Retrying "
+                ++ show r
+              go (r + 1)
+            Right (Just s) -> return $ B.take (fromIntegral bBlockSize) s
+  go 0
+
+timeoutWrite :: BlockCopy -> Int -> B.ByteString -> IO Bool
+timeoutWrite b@BlockCopy { bBlockSize, ..} block s
+  | B.length s == fromIntegral bBlockSize = do
+    x <- Tim.timeout ioTimeout (B.writeFile (blockPath b block) s)
+    case x of
+      Nothing -> return False
+      Just _ -> return True
+  | otherwise = do
+    ln $ "Write of incorrectly sized block! length s = "
+      ++ show (B.length s) ++ " but blockSize = " ++ show bBlockSize
+    timeoutWrite b block (blit (B.replicate (fromIntegral bBlockSize) 0) 0 s)
+
+writeBlock :: BlockCopy -> Int -> B.ByteString -> IO ()
+writeBlock b block s = do
+  let go r
+        | r >= maxRetries = Ex.throw (userError "Timeout")
+        | otherwise = do
+          x <- timeoutWrite b block s
+          case x of
+            True -> return ()
+            False -> do
+              ln $ "Timeout writing block " ++ show block ++ ". Retrying "
+                ++ show r
+              go (r + 1)
+  go 0
 
 mkFuseRead :: BlockCopy -> FilePath -> Handle -> T.ByteCount -> T.FileOffset
   -> IO (Either E.Errno B.ByteString)
@@ -207,24 +253,26 @@ mkFuseWrite store@BlockCopy { bBlockSize, .. } "/disk" _ string offset = do
         in if bl == block && blockOffset /= 0
           then do
             currentContents <- readBlock store bl
-            B.writeFile (blockPath store bl)
+            writeBlock store bl
               (blit currentContents (fromIntegral blockOffset) string)
           else if bl == lastBlock && B.length mySuffix < fromIntegral bBlockSize
             then do
               currentContents <- readBlock store bl
-              B.writeFile (blockPath store bl)
-                (blit currentContents 0 mySuffix)
+              writeBlock store bl (blit currentContents 0 mySuffix)
             else do
-              B.writeFile (blockPath store bl)
-                (B.take (fromIntegral bBlockSize) mySuffix))
+              writeBlock store bl (B.take (fromIntegral bBlockSize) mySuffix))
         [block..lastBlock]
   ln $ "Completed write offset=" ++ show offset ++ " length="
     ++ show (B.length string)
   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
+mkFuseGetFileSystemStats :: BlockCopy -> String
+  -> IO (Either E.Errno F.FileSystemStats)
+mkFuseGetFileSystemStats BlockCopy { bBlockSize, bSize, .. } _ =
+  return $ Right
+    $ F.FileSystemStats (fromIntegral bBlockSize)
+      (fromIntegral bSize `div` fromIntegral bBlockSize) 0 0 0 0 0
 
 fuseFlush :: FilePath -> Handle -> IO E.Errno
 fuseFlush _ _ = return E.eOK
@@ -329,7 +377,7 @@ blockCopyMain = do
           fuseRemoveDirectory fuseCreateSymbolicLink fuseRename fuseCreateLink
           fuseSetFileMode fuseSetOwnerAndGroup
           (mkFuseSetFileSize bs) fuseSetFileTimes fuseOpen (mkFuseRead bs)
-          (mkFuseWrite bs) fuseGetFileSystemStats
+          (mkFuseWrite bs) (mkFuseGetFileSystemStats bs)
           fuseFlush fuseRelease fuseSynchronizeFile fuseOpenDirectory
           (mkFuseReadDirectory bs) fuseReleaseDirectory
           fuseSynchronizeDirectory fuseAccess fuseInit fuseDestroy)