{-# LANGUAGE ScopedTypeVariables #-}

-- | Mostly internal utilities for use by the rest of the library. Subject to
-- removal without further notice.
module Storage.Hashed.Utils where

import Prelude hiding ( lookup, catch )
import qualified Bundled.SHA256 as SHA
import System.Mem( performGC )
import System.IO.MMap( mmapFileByteString )
import Bundled.Posix( getFileStatus, fileSize )
import System.Directory( getCurrentDirectory, setCurrentDirectory )
import System.FilePath( (</>), isAbsolute )
import Data.Int( Int64 )
import Control.Exception.Extensible( catch, bracket, SomeException(..) )
import Control.Monad( when )

import Foreign.ForeignPtr( withForeignPtr )
import Foreign.Ptr( plusPtr )
import Data.ByteString.Internal( toForeignPtr, memcpy )

import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS

newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Read)

makeHash :: BS.ByteString -> Hash
makeHash str = case BS.split '-' str of
                 [h] -> Hash (Nothing, h)
                 [s, h] -> Hash (Just $ read $ BS.unpack s, h)
                 _ -> error $ "Bad hash string " ++ show str

hashSetSize :: Hash -> Int64 -> Hash
hashSetSize (Hash (_,h)) s = Hash (Just s, h)

-- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be
-- fed to (uncurry mmapFileByteString) or similar.
type FileSegment = (FilePath, Maybe (Int64, Int))

-- | Bad and ugly. Only works well with single-chunk BL's.
sha256 :: BL.ByteString -> Hash
sha256 = makeHash . BS.pack . SHA.sha256 . BS.concat . BL.toChunks

-- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap.
readSegment :: FileSegment -> IO BL.ByteString
readSegment (f,range) = do
 x <- mmapFileByteString f range
   `catch` (\(_::SomeException) -> do
                     size <- fileSize `fmap` getFileStatus f
                     if size == 0
                        then return BS.empty
                        else performGC >> mmapFileByteString f range)
 return $ BL.fromChunks [x]
{-# INLINE readSegment #-}

-- | Run an IO action with @path@ as a working directory. Does neccessary
-- bracketing.
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name =
    bracket
        (do cwd <- getCurrentDirectory
            when (name /= "") (setCurrentDirectory name)
            return cwd)
        (\oldwd -> setCurrentDirectory oldwd
                     `catch` \(_::SomeException) -> return ())
        . const

-- Ternary kind of operator. Just a concise way to write if.
(?) :: Bool -> (a, a) -> a
w ? (a,b) = if w then a else b
{-# INLINE (?) #-}

makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p = do
  cwd <- getCurrentDirectory
  return $! isAbsolute p ? (p, cwd </> p)

-- Wow, unsafe.
pokeBS :: BS.ByteString -> BS.ByteString -> IO ()
pokeBS to from =
    do let (fp_to, off_to, len_to) = toForeignPtr to
           (fp_from, off_from, len_from) = toForeignPtr from
       when (len_to /= len_from) $ fail $ "Length mismatch in pokeBS: from = "
            ++ show len_from ++ " /= to = " ++ show len_to
       withForeignPtr fp_from $ \p_from ->
         withForeignPtr fp_to $ \p_to ->
           memcpy (plusPtr p_to off_to)
                  (plusPtr p_from off_from)
                  (fromIntegral len_to)