path: root/src/Lib.hs

{-
 - 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