aboutsummaryrefslogtreecommitdiffstats
path: root/src/Lib.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Lib.hs')
-rw-r--r--src/Lib.hs280
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
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 04:15:57 +0000