Improve logging and change all kinds of things

In this stage of rapid development it doesn't make sense
to write accurate and detailed commit messages. I'm lying:
I'm just lazy.

1 files changed, 91 insertions, 35 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index c90888b..d50e6aa 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
 {-
  - Copyright 2018 Raymond Hogenson
 
@@ -34,27 +35,38 @@ 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
+import qualified Data.List as L
+import qualified Data.Maybe as Ma
 
 newtype Handle = Handle ()
 
-data BlockCopy =
-  BlockCopy (IOR.IORef (M.Map Int RWL.RWLock)) FilePath
+data BlockCopy = BlockCopy
+  { bLocks :: IOR.IORef (M.Map Int RWL.RWLock)
+  , bStore :: FilePath
+  , bSize :: T.FileOffset
+  , bBlockSize :: T.ByteCount }
 
 statsMessage :: BlockCopy -> IO B.ByteString
-statsMessage (BlockCopy _ store) = do
-  let stats = "store: " ++ store ++ "\n"
+statsMessage BlockCopy { bStore, bSize, bBlockSize, ..} = do
+  let stats = "store: " ++ bStore ++ "\nsize: " ++ show bSize
+        ++ "\nblock-size: " ++ show bBlockSize ++ "\n"
   return $ C8.pack stats
 
 mkFuseGetFileStat :: BlockCopy -> FilePath -> IO (Either E.Errno F.FileStat)
-mkFuseGetFileStat b s = do
+mkFuseGetFileStat b@BlockCopy { bSize, .. } 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 $ 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
+    "/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)
@@ -109,17 +121,14 @@ fuseOpen "/disk" _ _ = do
 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
+blockPath BlockCopy { bStore, .. } block = bStore FP.</> show block
 
 getLock :: BlockCopy -> Int -> IO RWL.RWLock
-getLock (BlockCopy locks _) block = do
+getLock BlockCopy { bLocks, .. } block = do
   newLock <- RWL.new
   IOR.atomicModifyIORef'
-    locks (\m ->
+    bLocks (\m ->
       case M.lookup block m of
         Nothing -> (M.insert block newLock m, newLock)
         Just a -> (m, a))
@@ -141,28 +150,30 @@ withWriteLocks b blocks op = do
   return x
 
 readBlock :: BlockCopy -> Int -> IO B.ByteString
-readBlock b block = do
+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 blockSize) 0
-    Right s -> return $ B.take (fromIntegral blockSize) s
+      return $ B.replicate (fromIntegral bBlockSize) 0
+    Right s -> return $ B.take (fromIntegral bBlockSize) s
 
 mkFuseRead :: BlockCopy -> FilePath -> Handle -> T.ByteCount -> T.FileOffset
   -> IO (Either E.Errno B.ByteString)
-mkFuseRead store "/disk" _ count offset = do
+mkFuseRead store@BlockCopy { bBlockSize, .. } "/disk" _ count offset = do
   ln $ "Read /disk count=" ++ show count ++ " offset=" ++ show offset
-  let block = fromIntegral offset `div` fromIntegral blockSize
+  let block = fromIntegral offset `div` fromIntegral bBlockSize
   let lastBlock = fromIntegral (offset + fromIntegral count - 1)
-        `div` fromIntegral blockSize
-  let blockOffset = offset `mod` fromIntegral blockSize
-  fmap
+        `div` fromIntegral bBlockSize
+  let blockOffset = offset `mod` fromIntegral bBlockSize
+  result <- 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]
+  ln $ "Completed read count=" ++ show count ++ " offset=" ++ show offset
+  return result
 mkFuseRead b "/stats" _ count offset = do
   bs <- statsMessage b
   return $ Right $ B.take (fromIntegral count) $ B.drop (fromIntegral offset) bs
@@ -181,32 +192,34 @@ blit a i x = B.intercalate B.empty [B.take i a, B.take (B.length a - i) x, B.dro
 
 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
+mkFuseWrite store@BlockCopy { bBlockSize, .. } "/disk" _ string offset = do
+  ln $ "Write offset=" ++ show offset ++ " size=" ++ show (B.length string)
+  let block = fromIntegral offset `div` fromIntegral bBlockSize
   let lastBlock = fromIntegral (offset + fromIntegral (B.length string) - 1)
-        `div` fromIntegral blockSize
-  let blockOffset = offset `mod` fromIntegral blockSize
+        `div` fromIntegral bBlockSize
+  let blockOffset = offset `mod` fromIntegral bBlockSize
   withWriteLocks store [block..lastBlock] $ P.parallel_
     $ map (\bl ->
         let mySuffix =
               B.drop
-                ((bl - 1) * fromIntegral blockSize + fromIntegral blockOffset)
+                ((bl - 1) * fromIntegral bBlockSize + 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
+          else if bl == lastBlock && B.length mySuffix < fromIntegral bBlockSize
             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))
+                (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
 
@@ -255,18 +268,61 @@ handler e = do
   ln $ "ERROR: " ++ show e
   return E.eFAULT
 
+getArg :: Char -> [String] -> (Maybe String, [String])
+getArg _ [] = (Nothing, [])
+getArg x [l]
+  | ['-', x] `L.isPrefixOf` l = (Just $ drop 2 l, [])
+  | otherwise = (Nothing, [l])
+getArg x (l : a : ls)
+  | ['-', x] == l = (Just a, ls)
+  | ['-', x] `L.isPrefixOf` l = (Just $ drop 2 l, a : ls)
+  | otherwise = let (h, ll) = getArg x (a : ls) :: (Maybe String, [String])
+                in (h, l : ll)
+
+sizeMap :: M.Map String Integer
+sizeMap =
+  M.fromList
+    [ ("c", 1), ("w", 2), ("b", 512), ("kB", 1000), ("K", 1024)
+    , ("MB", 1000*1000), ("M", 1024*1024), ("xM", 1024*1024)
+    , ("GB", 1000*1000*1000), ("G", 1024*1024*1024), ("T", 1024^(4 :: Integer))
+    , ("P", 1024^(5 :: Integer)), ("E", 1024^(6 :: Integer)), ("Z", 1024^(7 :: Integer)), ("Y", 1024^(8 :: Integer)) ]
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead = fmap fst . Ma.listToMaybe . reads
+
+parseSize :: String -> Maybe Integer
+parseSize s =
+  case (M.lookup (drop (length s - 2) s) sizeMap,
+        M.lookup (drop (length s - 1) s) sizeMap) of
+    (Just e, _) -> (* e) <$> maybeRead (take (length s - 2) s)
+    (_, Just e) -> (* e) <$> maybeRead (take (length s - 1) s)
+    _ -> maybeRead s
+
+mapFst :: (a -> b) -> (a, c) -> (b, c)
+mapFst f (a, b) = (f a, b)
+
 blockCopyMain :: IO ()
 blockCopyMain = do
   locks <- IOR.newIORef M.empty
   prog <- En.getProgName
   args <- En.getArgs
-  case args of
-    [] -> putStrLn "please store"
-    (store : mArgs) -> do
+  case getArg 'b' args of
+    (Nothing, _) -> putStrLn "please store"
+    (Just store, mArgs) -> do
       ln "main"
       trueStore <- D.canonicalizePath store
-      let bs = BlockCopy locks trueStore
-      F.fuseRun prog mArgs
+      let (size, nextArgs) =
+            case mapFst (>>= parseSize) $ getArg 's' mArgs of
+              (Nothing, _) -> (maxBound, mArgs)
+              (Just ssize, aa) -> (fromIntegral ssize, aa)
+      let (blockSize, fuseArgs) =
+            case mapFst (>>= parseSize) $ getArg 'w' nextArgs of
+              (Nothing, _) -> (4096, nextArgs)
+              (Just bSize, aa) -> (fromIntegral bSize, aa)
+      let bs = BlockCopy
+            { bLocks=locks, bStore=trueStore, bSize=size
+            , bBlockSize=blockSize }
+      F.fuseRun prog fuseArgs
         (F.FuseOperations (mkFuseGetFileStat bs) fuseReadSymbolicLink
           fuseCreateDevice
           fuseCreateDirectory fuseRemoveLink