InterfaceMMap.hsc

{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Conjure.FileSystem.InterfaceMMap
-- Copyright   :  (c) Lemmih 2006
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (requires posix)
--
-- Fast mmap based backend.
-----------------------------------------------------------------------------
module Conjure.FileSystem.InterfaceMMap where
{-    ( open
    ) where -}

#include <unistd.h>
#ifndef _POSIX_MAPPED_FILES

open :: Torrent -> IO Backend
open = error "Conjure.FileSystem.InterfaceMMap.open: mmap backend not available"

#else

#include <sys/mman.h>

import Conjure.Torrent
import Conjure.Types

import System.IO
import Data.List
import Data.Maybe
import Control.Monad
import Control.Exception
import Foreign
import Foreign.C

import System.FilePath

import System.Posix

import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS (unsafeUseAsCStringLen)
import Data.ByteString (ByteString)

open :: Torrent -> IO Backend
open torrent
    = do mmapped <- mapM (uncurry mmap) files
         return $ Backend
                    { close       = mapM_ (munmap . mmapBS) mmapped
                    , readPiece   = mmapReadPiece torrent mmapped
                    , readPiece'  = mmapReadPiece' torrent mmapped
                    , writeBlock  = mmapWriteBlock torrent mmapped
                    , readBlock   = mmapReadBlock torrent mmapped
                    , commitPiece = mmapCommitPiece torrent mmapped
                    }
  where files = case tInfo torrent of
                  SingleFile {tName=name,tLength=len} -> [(name,len)]
                  MultiFile {tName=name,tFiles=files} -> map (\f -> (name </> filePath f,fileLength f)) files


mmapReadPiece :: Torrent -> [MMapped] -> Int -> IO ByteString
mmapReadPiece torrent mmapped pieceNum
    = fmap (fromMaybe $ error msg) (mmapReadPiece' torrent mmapped pieceNum)
    where msg = "Failed to read piece."

mmapReadPiece' :: Torrent -> [MMapped] -> Int -> IO (Maybe ByteString)
mmapReadPiece' torrent mmapped pieceNum
    = readFromTorrent' mmapped entities
      where entities = getPieceFilePaths torrent pieceNum

mmapWriteBlock :: Torrent -> [MMapped] -> Int -> Int -> ByteString -> IO ()
mmapWriteBlock torrent mmapped pieceNum offset block
    = worker block entries
    where entries = getBlockFilePaths torrent pieceNum offset (BS.length block)
          worker str [] = assert (BS.null str) $ return ()
          worker str ((path, start, size):xs)
              = do let block = getMMapped mmapped path
                   assureSize block (start+size)
                   writeData (BS.drop start $ mmapBS block) (BS.take size str)
                   worker (BS.drop size str) xs

mmapReadBlock :: Torrent -> [MMapped] -> Int -> Int -> Int -> IO ByteString
mmapReadBlock torrent mmapped pieceNum offset len
    = readFromTorrent mmapped entities
    where entities = getBlockFilePaths torrent pieceNum offset len

mmapCommitPiece :: Torrent -> [MMapped] -> Int -> IO ()
mmapCommitPiece torrent mmapped pieceNum
    = forM_ entities $ \(path, _, _) ->
      do let block = getMMapped mmapped path
         msync (mmapBS block)
    where entities = getPieceFilePaths torrent pieceNum

--------------------------------------------------------------
-- Utilities
--------------------------------------------------------------

getMMapped :: [MMapped] -> FilePath -> MMapped
getMMapped mmapped path = fromMaybe err $ find (\m -> mmapPath m == path) mmapped
    where err = error $ "Failed to locate mmapped file: " ++ path


readFromTorrent :: [MMapped]
                -> [(FilePath, Int, Int)]
                -> IO ByteString
readFromTorrent mmapped entities
    = do mbBlock <- readFromTorrent' mmapped entities
         case mbBlock of
           Just block -> return block
           Nothing    -> error "Failed to read data block."

readFromTorrent' :: [MMapped]-> [(FilePath, Int, Int)] -> IO (Maybe ByteString)
readFromTorrent' mmapped entities
    = reader entities []
    where reader [] acc = return (Just (BS.concat (reverse acc)))
          reader ((path, start, size):xs) acc
              = do let block = getMMapped mmapped path
                   fSize <- liftM (fromIntegral.fileSize) $ getFdStatus (mmapFd block)
                   if (fSize < start+size)
                      then return Nothing
                      else reader xs (BS.take size (BS.drop start (mmapBS block)):acc)



--------------------------------------------------------------
-- MMap functions
--------------------------------------------------------------

prot_read, prot_write, map_shared :: (Num t) => t
prot_read = #{const PROT_READ}
prot_write = #{const PROT_WRITE}

map_shared = #{const MAP_SHARED}

foreign import ccall unsafe "mmap" c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr b)
foreign import ccall unsafe "munmap" c_munmap :: Ptr a -> CSize -> IO CInt
foreign import ccall unsafe "msync" c_msync :: Ptr a -> CSize -> CInt -> IO CInt

data MMapped =
    MMapped { mmapFd   :: Fd
            , mmapPath :: FilePath
            , mmapBS   :: ByteString
            }

assureSize :: MMapped -> Int -> IO ()
assureSize block minsize
    = do status <- getFdStatus (mmapFd block)
         let size = fromIntegral $ fileSize status
         when (minsize > size)
            $ setFdSize (mmapFd block) (fromIntegral minsize)


writeData :: ByteString -> ByteString -> IO ()
writeData desc src
    = BS.unsafeUseAsCStringLen desc $ \(descAddr,descLen) ->
      BS.unsafeUseAsCStringLen src $ \(srcAddr,srcLen) ->
      do BS.memcpy (castPtr descAddr) (castPtr srcAddr) (fromIntegral $ min descLen srcLen)
         return ()

mmap :: FilePath -> Int -> IO MMapped
mmap path length
    = do Fd fd <- openFd path ReadWrite Nothing defaultFileFlags{append = True}
         addr <- c_mmap nullPtr (fromIntegral length) (prot_read .|. prot_write) map_shared fd 0
         return =<< (liftM $ MMapped (Fd fd) path) (BS.packCStringLen (addr, length))


munmap :: ByteString -> IO ()
munmap bs
    = BS.unsafeUseAsCStringLen bs $ \(addr,len) ->
      do c_munmap addr (fromIntegral len)
         return ()

ms_sync, ms_async, ms_invalidate :: (Num t) => t
ms_sync = #{const MS_SYNC}
ms_async = #{const MS_ASYNC}
ms_invalidate = #{const MS_INVALIDATE}

msync :: ByteString -> IO ()
msync bs
    = BS.unsafeUseAsCStringLen bs $ \(addr,len) ->
      do c_msync (castPtr addr) (fromIntegral len) ms_sync
         return ()

#endif