InterfaceNaive.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Conjure.FileSystem.InterfaceNaive
-- Copyright   :  (c) Lemmih 2005-2006
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Naive filesystem interface. This backend tries to be as
-- portable as possible.
-----------------------------------------------------------------------------
module Conjure.FileSystem.InterfaceNaive
    ( open
    ) where

import Conjure.Torrent              ( getPieceFilePaths
                                    , getBlockFilePaths )
import Conjure.Types

import System.IO
import Data.Map (Map)
import Data.Maybe
import Control.Monad                ( liftM, when, join )
import qualified Data.Map as Map
import Control.Concurrent
import Control.Exception
import Foreign                      ( mallocForeignPtrArray
                                    , withForeignPtr, advancePtr )


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

type Handles = MVar (Map FilePath Handle)

open :: Torrent -> IO Backend
open torrent
    = do handles <- newMVar Map.empty
         return $ Backend
                    { close       = naiveClose handles
--                    , sendPiece = naiveSendPiece torrent handles
                    , readPiece   = naiveReadPiece torrent handles
                    , readPiece'  = naiveReadPiece' torrent handles
                    , writeBlock  = naiveWriteBlock torrent handles
                    , readBlock   = naiveReadBlock torrent handles
                    , commitPiece = const (return ())
                    }

naiveClose :: Handles -> IO ()
naiveClose mvar
    = modifyMVar_ mvar $ \handleMap ->
        do mapM_ hClose (Map.elems handleMap)
           return (Map.empty)

naiveSendPiece :: Torrent -> Handles -> Int -> Handle -> IO ()
naiveSendPiece torrent handles pieceNum peer
    = do piece <- naiveReadPiece torrent handles pieceNum
         BS.hPut peer piece
         -- force finalization of the piece?

naiveReadPiece :: Torrent -> Handles -> Int -> IO ByteString
naiveReadPiece torrent handles pieceNum
    = fmap (fromMaybe $ error msg) (naiveReadPiece' torrent handles pieceNum)
    where msg = "Failed to read piece."

naiveReadPiece' :: Torrent -> Handles -> Int -> IO (Maybe ByteString)
naiveReadPiece' torrent handles pieceNum
    = readFromTorrent' handles entities
      where entities = getPieceFilePaths torrent pieceNum

naiveWriteBlock :: Torrent -> Handles -> Int -> Int -> ByteString -> IO ()
naiveWriteBlock torrent handles 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 withFileHandle handles path $ \handle ->
                       do prepareHandle handle start size
                          BS.hPut handle (BS.take size str)
                   worker (BS.drop size str) xs

naiveReadBlock :: Torrent -> Handles -> Int -> Int -> Int -> IO ByteString
naiveReadBlock torrent handles pieceNum offset len
    = readFromTorrent handles entities
    where entities = getBlockFilePaths torrent pieceNum offset len


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

withFileHandle :: Handles -> FilePath -> (Handle -> IO a) -> IO a
withFileHandle mvar path action
    = modifyMVar mvar $ \handleMap ->
        case Map.lookup path handleMap of
          Just handle -> do a <- action handle
                            return (handleMap, a)
          Nothing -> do handle <- openFile path ReadWriteMode
                        a <- action handle
                        return (Map.insert path handle handleMap, a)

prepareHandle :: Handle -> Int -> Int -> IO ()
prepareHandle handle pos len
    = do size <- liftM fromIntegral $ hFileSize handle
         when (size < pos+len)
            $ hSetFileSize handle (fromIntegral $ pos+len)
         hSeek handle AbsoluteSeek (fromIntegral pos)


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

readFromTorrent' :: Handles
                 -> [(FilePath, Int, Int)] -- ^ Block information.
                 -> IO (Maybe ByteString)
readFromTorrent' handles entities
    = do fp <- mallocForeignPtrArray len
         let reader [] _ = return (Just (BS.fromForeignPtr fp 0 len))
             reader ((path, start, size):xs) ptr
              = join $
                withFileHandle handles path $ \handle ->
                       do fSize <- liftM fromIntegral $ hFileSize handle
                          if (fSize < start+size)
                             then return (return Nothing)
                             else do hSeek handle AbsoluteSeek (fromIntegral start)
                                     hGetBuf handle ptr size
                                     return (reader xs (ptr `advancePtr` size))
         withForeignPtr fp (reader entities)
    where len = sum [ pSize | (_,_,pSize) <- entities ]