{-# LANGUAGE Rank2Types, ExistentialQuantification #-}
module Halfs.BufferBlock
        ( BufferBlock           -- abstract
        , bbDirty
        , bbLock
        , bbDiskAddr
        , bbRawDevice
        , bbRecent
        , mkBufferBlock
        , incLock
        , decLock
        , clearLock
        , getLock
        , setDirty
        , getDirty
        , getDiskAddr
        , setDiskAddr
        , setRawDevice
        , getRawDevice
        , setRecent
        , getRecent
        , writeToBufferBlock
        , readFromBufferBlock
        , bufferBlockCursorIntoPointers
        , BufferBlockCursor(..) -- for Cache only
        , Alloc(..)
        , copyFromBufferBlock
        , copyToBufferBlock
        , copyBufferBlock
        , zeroBufferBlock
        , deadbeefBufferBlock
        , startBufferBlockCursor
        , ReadBuffer            -- abstract
        , readBuffer
        , doReadBuffer
        , diskAddressListFromBufferBlock

        , PartBufferBlock
        , putPartBufferBlock
        , getPartBufferBlock
        , mkInodeBlock
        , mkDiskAddressBlock
        , devBufferRead
        , devBufferWrite


        , bbDebugOn
        , bbDebugOff
        , bbDebug

        ) where

import Binary  -- (FixedBinHandle,BinaryHandle, openFixedBinMem, sizeFixedBinMem)
import Halfs.Utils (DiskAddress, bytesPerBlock, bytesPerBlockPointer,
                   bytesPerInode,
                   blockPointersPerIndirectBlock)
import Control.Exception(assert)
import System.RawDevice (BufferBlockHandle, RawDevice, zeroBufferBlockHandle)
import qualified System.RawDevice (devBufferRead, devBufferWrite)
import Data.IORef
import Data.Integral(INInt, inIntToInt)
import Halfs.Inode (Inode)
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad(when)

data BufferBlock s =
    BufferBlock { bbBuffer    :: !(BufferBlockHandle s) -- later will just be a buffer block
                , bbDirty     :: !(IORef Bool) -- dirty bit
                , bbLock      :: !(IORef Int)  -- number of locks on this buffer
                , bbRecent    :: !(IORef Bool)   -- marked if recently used
                , bbRawDevice :: !(IORef RawDevice)
                , bbDiskAddr  :: !(IORef DiskAddress)
                }

-- This should only be used inside BufferBlockCache, or for bootstrapping.

mkBufferBlock :: BufferBlockHandle s -> RawDevice -> DiskAddress -> IO (BufferBlock s)
mkBufferBlock h dev addr = do
 dirtyRef   <- newIORef False
 lockRef    <- newIORef 0
 recentRef  <- newIORef True
 addrRef    <- newIORef addr
 devRef     <- newIORef dev
 let bb = BufferBlock h dirtyRef lockRef recentRef devRef addrRef
 bbDebug bb "mkBufferBlock"
 return $ bb

setDirty :: BufferBlock s -> Bool -> IO ()
setDirty bb val = bbDebugSetter bb "setDirty" $ writeIORef (bbDirty bb) val

getDirty :: BufferBlock s -> IO Bool
getDirty bb = bbDebugGetter bb "getDirty" $ readIORef (bbDirty bb)

incLock :: BufferBlock s -> IO ()
incLock bb = bbDebugSetter bb "incLock" $  modifyIORef (bbLock bb) $ succ

decLock :: BufferBlock s -> IO ()
decLock bb = bbDebugSetter bb "decLock" $  modifyIORef (bbLock bb) $ pred

clearLock :: BufferBlock s -> IO ()
clearLock bb = bbDebugSetter bb "clearLock" $  writeIORef (bbLock bb) $ 0

getLock :: BufferBlock s -> IO Int
getLock bb = bbDebugGetter bb "getLock" $  readIORef (bbLock bb)

getDiskAddr :: BufferBlock s -> IO DiskAddress
getDiskAddr bb = bbDebugGetter bb "getDiskAddr" $ readIORef (bbDiskAddr bb)

setDiskAddr :: BufferBlock s -> DiskAddress -> IO ()
setDiskAddr bb da = bbDebugSetter bb "setDiskAddr" $ writeIORef (bbDiskAddr bb) da

getRawDevice :: BufferBlock s -> IO RawDevice
getRawDevice bb = bbDebugGetter bb "getRawDevice" $ readIORef (bbRawDevice bb)

setRawDevice :: BufferBlock s -> RawDevice -> IO ()
setRawDevice bb da = bbDebugSetter bb "setRawDevice" $ writeIORef (bbRawDevice bb) da

setRecent :: BufferBlock s -> Bool -> IO ()
setRecent bb val = bbDebugSetter bb "setRecent" $ writeIORef (bbRecent bb) val

getRecent :: BufferBlock s -> IO Bool
getRecent bb = bbDebugGetter bb "getRecent" $ readIORef (bbRecent bb)

data Alloc = forall a . (Binary a, Show a) => Alloc a

data BufferBlockCursor s = BufferBlockCursor (Bin ())
        deriving Show

startBufferBlockCursor :: BufferBlockCursor a
startBufferBlockCursor = BufferBlockCursor $ BinPtr 0

-- TODO: Add asserts
bufferBlockCursorIntoPointers :: INInt -> BufferBlockCursor s
bufferBlockCursorIntoPointers n =
   assert (n >= 0 && inIntToInt n < blockPointersPerIndirectBlock) $
        BufferBlockCursor $ BinPtr $ inIntToInt n * bytesPerBlockPointer

writeToBufferBlock :: BufferBlock s -> BufferBlockCursor s -> [Alloc] -> IO ()
writeToBufferBlock buffer (BufferBlockCursor c) allocs =
 bbDebugSetter buffer ("writeToBufferBlock: " ++ show (c,[ show a | Alloc a <- allocs])) $
 do seekBin (bbBuffer buffer) c
    write allocs
    writeIORef (bbDirty buffer) True
  where
    write (Alloc v : rest) = do
        put_ (bbBuffer buffer) v
        write rest
    write [] = return ()


readFromBufferBlock :: (Show a,Binary a) => BufferBlock s -> BufferBlockCursor s -> IO a
readFromBufferBlock buffer (BufferBlockCursor cur) =
  bbDebugGetter buffer ("readFromBufferBlock" ++ show cur) $
  do seekBin (bbBuffer buffer) cur
     get (bbBuffer buffer)


copyFromBufferBlock :: (BinaryHandle h) => BufferBlock s -> Int ->  h -> Int -> Int -> IO Int
copyFromBufferBlock bb c buffer offset size = do
  bbDebugSetter bb ("copyFromBufferBlock: " ++ show (c,offset,size)) $ do
  seekBin (bbBuffer bb) (BinPtr c)
  seekBin buffer (BinPtr offset)
  copyBytes (bbBuffer bb) buffer size
  return size

copyToBufferBlock :: (BinaryHandle h) => h -> Int -> BufferBlock s -> Int -> Int -> IO Int
copyToBufferBlock buffer offset bb c size = do
  bbDebugSetter bb ("copyToBufferBlock: " ++ show (c,offset,size)) $ do
  seekBin buffer (BinPtr offset)
  seekBin (bbBuffer bb) (BinPtr c)
  copyBytes buffer (bbBuffer bb) size
  writeIORef (bbDirty bb) True
  return size

{- UNUSED:
printHead :: (String, BinHandle) -> IO ()
printHead(str,b) = do
  resetBin b
  vs <- sequence $ replicate 10 (get $ b)
  print (str,vs :: [DiskAddress])
  resetBin b
-}

copyBufferBlock :: BufferBlock s -> BufferBlock t ->  IO ()
copyBufferBlock b1 b2 = do
     bbDebug b1 "(before)src:copyBufferBlock"
     bbDebug b2 "(before)dest:copyBufferBlock"
     resetBin (bbBuffer b1)
     resetBin (bbBuffer b2)
     copyBytes (bbBuffer b1) (bbBuffer b2) bytesPerBlock
     writeIORef (bbDirty b2) True
     bbDebug b1 "(after)src:copyBufferBlock"
     bbDebug b2 "(after)dest:copyBufferBlock"
     return ()

zeroBufferBlock :: BufferBlock s -> IO ()
zeroBufferBlock buffer =
    bbDebugSetter buffer ("zeroBufferBlock") $ do
    zeroBufferBlockHandle (bbBuffer buffer)

deadbeefBufferBlock :: BufferBlock s -> IO ()
deadbeefBufferBlock buffer =
    bbDebugSetter buffer ("deadbeefBufferBlock") $ do
    writeToBufferBlock buffer (BufferBlockCursor (BinPtr 0))
                [ Alloc (0xDEADBEEF :: DiskAddress) | _ <- take blockPointersPerIndirectBlock $ [(0::Int)..] ]


diskAddressListFromBufferBlock :: BufferBlock s -> IO [DiskAddress]
diskAddressListFromBufferBlock bb = do
  bbDebugGetter bb ("diskAddressListFromBufferBlock") $ do
  resetBin (bbBuffer bb)
  sequence $ replicate blockPointersPerIndirectBlock (get $ bbBuffer bb)

------------------------------------------------------------------------------

data ReadBuffer a = ReadBuffer (forall s . BufferBlockHandle s -> IO a)

instance Monad ReadBuffer where
   return a = ReadBuffer (\ _ -> return a)
   m >>= k = ReadBuffer (\ h -> case m of
                                 ReadBuffer m1 -> do r <- m1 h
                                                     case k r of
                                                       ReadBuffer m2 -> m2 h)

readBuffer :: (Binary a) => ReadBuffer a
readBuffer = ReadBuffer get

doReadBuffer :: BufferBlock s -> BufferBlockCursor s -> ReadBuffer a -> IO (a,BufferBlockCursor s)
doReadBuffer bb (BufferBlockCursor c) (ReadBuffer rb) = do
  seekBin (bbBuffer bb) c
  r <- rb (bbBuffer bb)
  c' <- tellBin (bbBuffer bb)
  return (r,BufferBlockCursor c')


------------------------------------------------------------------------------

-- A PartBufferBlock is a reference to a specific slice of a BufferBlock.

data PartBufferBlock a s = PartBufferBlock (BufferBlock s) (BufferBlockCursor s)

putPartBufferBlock :: (Show a,Binary a) => PartBufferBlock a s -> a -> IO ()
putPartBufferBlock (PartBufferBlock bb c) a =
  bbDebugSetter bb ("putPartBufferBlock") $ do
  writeToBufferBlock bb c [Alloc a]

getPartBufferBlock :: (Show a,Binary a) => PartBufferBlock a s -> IO a
getPartBufferBlock (PartBufferBlock bb c) =
  bbDebugGetter bb ("getPartBufferBlock") $ do
  readFromBufferBlock bb c

------------------------------------------------------------------------------

mkInodeBlock :: BufferBlock s -> Int -> IO (PartBufferBlock Inode s)
mkInodeBlock bb i = assert (ix >= 0 && ix < bytesPerBlock) $
                    return $ PartBufferBlock bb (BufferBlockCursor $ BinPtr ix)
  where
        ix = i * bytesPerInode


mkDiskAddressBlock :: BufferBlock s -> Int -> IO (PartBufferBlock DiskAddress s)
mkDiskAddressBlock bb i = assert (ix >= 0 && ix < bytesPerBlock) $
                    return $ PartBufferBlock bb (BufferBlockCursor $ BinPtr ix)
  where
        ix = i * bytesPerBlockPointer

------------------------------------------------------------------------------



devBufferRead :: RawDevice
              -> DiskAddress    -- ^Block number
              -> BufferBlock s -- ^Buffer
              -> IO ()
devBufferRead dev addr bb = do
  bbDebugSetter bb ("devBufferRead:" ++ show(dev,addr)) $ do
    System.RawDevice.devBufferRead dev addr (bbBuffer bb)

-- we use setter here to check that the write does not modify/trash its buffer.

devBufferWrite :: RawDevice    -- ^which disk?
               -> DiskAddress  -- ^Block number
               -> BufferBlock s  -- ^Buffer!
               -> IO ()
devBufferWrite dev addr bb = do
  bbDebugSetter bb ("devBufferWrite:" ++ show(dev,addr)) $ do
     System.RawDevice.devBufferWrite dev addr (bbBuffer bb)


{- UNUSED:
assertEqBufferBlockHandle :: BinHandle -> BinHandle -> IO ()
assertEqBufferBlockHandle b1 b2 = do
  resetBin b1
  resetBin b2
  sequence_ [ do v1 <- get b1
                 v2 <- get b2
                 when ((v1 :: Word32) /= v2) $ do
                                print $ "blocks are different(!) : " ++ show (i,v1,v2)
                                error ""
                 return $ ()
            | i <- take (bytesPerBlock `div` 4) [(0::Int)..]
            ]
  resetBin b1
  resetBin b2
-}

------------------------------------------------------------------------------

{-# NOINLINE debugRef #-}

debugRef :: IORef Bool
debugRef = unsafePerformIO $ newIORef False

noDebug :: Bool
noDebug = True

bbDebugOn :: IO ()
bbDebugOn = do writeIORef debugRef True
               putStrLn "bbDebugOn"

bbDebugOff :: IO ()
bbDebugOff = do writeIORef debugRef False
                putStrLn "bbDebugOff"

bbDebug :: BufferBlock s -> String -> IO ()
bbDebug _bb _msg | noDebug = return ()
bbDebug bb msg = do
   debug <- readIORef debugRef
   when debug $ do
        dirty  <- readIORef (bbDirty bb)
        lock   <- readIORef (bbLock bb)
        recent <- readIORef (bbRecent bb)
        raw    <- readIORef (bbRawDevice bb)
        addr   <- readIORef (bbDiskAddr bb)
        putStrLn $ msg
        putStrLn $ "BB { dirty=" ++ show dirty
                   ++ ", lock="  ++ show lock
                   ++ ", recent="  ++ show recent
                   ++ ", raw="  ++ show raw
                   ++ ", addr="  ++ show addr ++ "}"

bbDebugSetter :: BufferBlock s -> String -> IO a -> IO a
bbDebugSetter _bb _msg m | noDebug = m
bbDebugSetter bb msg m = do
  bbDebug bb ("before " ++ msg)
  r <- m
  bbDebug bb ("after " ++ msg)
  return r

bbDebugGetter :: (Show a) => BufferBlock s -> String -> IO a -> IO a
bbDebugGetter _bb _msg m | noDebug = m
bbDebugGetter bb msg m = do
  bbDebug bb msg
  r <- m
  debug <- readIORef debugRef
  when debug $ putStrLn $ "got " ++ show r
  return r