halfs-0.2: Halfs/SyncStructures.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Halfs.SyncStructures
-- 
-- Maintainer  :  Isaac Jones <ijones@galois.com>
-- Stability   :  alpha
-- Portability :  GHC
--
-- Explanation: Write various internal structures to disk.  Note that
-- the inode file never shrinks and the block map file never shrinks
-- or grows.  Therefore,
--
-- * When syncing directories, use truncate, since they might shrink a lot.  This includes the root directory.
--
-- * When syncing the inode map, use truncate, Its size might change.
--
-- * When syncing the inode file, use write.  It never shrinks.
--
-- * When syncing the block map, use write. Its size never changes.

module Halfs.SyncStructures (shortSyncFSRoot, syncFSRoot, syncDirectoryToFile) where

import Halfs.Directory(Directory(..), DirectoryCache(..), addDirectoryToCache,
                       dirCacheDirty, directoryCacheToList)
import Halfs.FSRoot(FSRoot(..), fsRootUpdateInodeCache, fsRootBmInode, FSStatus(..))
import Halfs.Inode (Inode(..), InodeMetadata(..))
import Halfs.FileHandle (fhInode, fileHandle, fhOpenTruncate, fhWrite, fileHandle,
                         FileHandle(..), FileMode(..))
import Halfs.BasicIO (BinHandle, writeDirectoryBin, syncInode,
                      writeBlockMapBin, writeInodeMapBin)
import Halfs.BinaryMonad(openBinMemRW, sizeBinMemRW)
import Halfs.TheBlockMap(TheBlockMap,bmDirty)
import Halfs.TheInodeMap(TheInodeMap(..))
import Data.Integral(INInt, intToINInt, INLong)
import Halfs.Utils(bytesPerBlock,
                   inodeMapInodeNum, blockMapInodeNum)
import Halfs.BufferBlockCache(syncBBCache)
import Halfs.FSState (FSWrite, modify, unsafeWriteGet, readToWrite,
                      putStrLnWriteRead)

-- base
import Control.Exception(assert)
import Control.Monad(mapM_, when)
import qualified Data.Map as Map

-- |writes it as a file, marks it as clean. block map file never
-- shrinks.  see notes in TheBlockMap.hs
syncBlockMapFile :: FSWrite ()
syncBlockMapFile = do
  fsroot@FSRoot{blockMap=theBlockMap} <- unsafeWriteGet
  let oldSize = num_bytes $ metaData $ fsRootBmInode fsroot

  syncObjectToFile theBlockMap
                   (bmDirty theBlockMap)
                   blockMapInodeNum
                   writeBlockMapBin
                   (updater oldSize) False
     where
     updater :: INLong -> Inode -> FSRoot -> FSRoot
     updater oldSize inode fsroot'@FSRoot{blockMap=bm}
           -- if it's grown, then it's still dirty:
         = let isDirty = (oldSize /= (num_bytes $ metaData inode))
            in fsroot'{blockMap=bm{bmDirty=isDirty}}

-- |Inode map file is open truncate, it can be resized.
syncInodeMapFile :: FSWrite ()
syncInodeMapFile = do
  fsroot <- unsafeWriteGet
  let inMap = inodeMap fsroot
  syncObjectToFile inMap
                   (imDirty inMap)
                   inodeMapInodeNum
                   writeInodeMapBin updater True
     where
     updater :: Inode -> FSRoot -> FSRoot
     updater _inode fsroot'@FSRoot{inodeMap=im}
         = fsroot'{inodeMap=im{imDirty=False}}

-- |Directories are open truncate, they can be resized.
syncDirectoryToFile :: Directory -> FSWrite ()
syncDirectoryToFile d = do
  -- the below updater may alter the inode, but don't worry
  -- fsrootupdateinodecache will handle that in the case of root
  -- directory.
  let inodeNum = fhInodeNum $ dirFile d
  syncObjectToFile (dirContents (assert (dirHasItsInodeNum d) d))
                    (dirDirty d)
                    inodeNum writeDirectoryBin (updater d) True
  -- FIX: If it's the root inode, we should mark it not dirty.
 where
  updater :: Directory -> Inode -> FSRoot -> FSRoot
  updater dir i fsr = let newR@FSRoot{directoryCache=c}
                            = fsRootUpdateInodeCache fsr i
                      in newR {directoryCache=addDirectoryToCache c dir{dirDirty=False}}

  dirHasItsInodeNum :: Directory -> Bool
  dirHasItsInodeNum (Directory FileHandle{fhInodeNum=i} c _)
      = case Map.lookup "." c of
         Nothing -> True -- might be root
         Just  a -> a == i

syncDirectoryCache :: FSWrite ()
syncDirectoryCache = do
  FSRoot{directoryCache=c} <- unsafeWriteGet
  when (dirCacheDirty c) (mapM_ syncDirectoryToFile (directoryCacheToList c))

  -- FIX: Possible race condition right here. updater calls modify, so
  -- we can't grab it HERE because of deadlock.  I think this is fixed
  -- by not marking the dcirecotry cache clean :( directories
  -- themselves have clean markers, though, so it should be OK.

  modify (\fsroot@FSRoot{directoryCache=_c} -> fsroot)
--       fsroot{directoryCache=markDirectoryCacheClean c})

syncObjectToFile :: a -- which object
                 -> Bool -- is dirty
                 -> INInt -- inode num
                 -> (BinHandle -> a -> FSWrite ()) -- writer function
                 -> (Inode -> FSRoot -> FSRoot) -- updater / dirty marker
                 -> Bool -- ^Truncate if dirty, otherwise write in-place. FIX: take open flag when that's fixed.
                 -> FSWrite ()
syncObjectToFile _ False _ _ _ _ =  return ()
syncObjectToFile obj True inodeNum writer updater trunc = do
  -- This file will always be less than INInt, not INLong
  newFileHandle <- if trunc
                   then fhOpenTruncate inodeNum
                   else return $ fileHandle inodeNum WriteMode

  {- FIX: For large filesystems, this may be a bad plan.. that is, we
  allocate a single block for the object, then start writing to it.
  Binary.hs will resize the array if necessary.  fhWrite then performs
  the actual write to the filesystem in blocks.  What we _should_ do
  is perform buffered writes to this array and _not_ resize it, so
  that we don't allocate one huge array for these structures.  OTOH,
  maybe that's not a big deal, as it'll only be an issue for really
  big filesystems?  -}

  buffer  <- openBinMemRW bytesPerBlock -- (num_bytes $ metaData fhInode fileHandle) -- initial size
  writer buffer obj -- may resize buffer!
  objSize <- sizeBinMemRW buffer
  (newFH, writtenNum)
      <- fhWrite newFileHandle buffer 0 (intToINInt objSize)
  inode <- readToWrite $ fhInode newFH
  assert (writtenNum == intToINInt objSize) $
          modify (updater inode)

-- |Sync the entire inode cache! Woohoo!
syncInodeCache :: FSWrite ()
syncInodeCache = do
  FSRoot{inodeCache=(inCache,isDirty)} <- unsafeWriteGet
  when isDirty (mapM_ syncInode (Map.elems inCache)
                >> modify (\fsroot -> fsroot{inodeCache=(fst $ inodeCache fsroot, False)}))

keepSyncingBlockMap :: FSWrite ()
keepSyncingBlockMap = do
  return()
  FSRoot{blockMap=theBlockMap} <- unsafeWriteGet
  when (bmDirty theBlockMap) (do syncBlockMapFile
                                 syncInodeCache
                                 FSRoot{blockMap=theBlockMap1} <- unsafeWriteGet
                                 -- only need to keep syncing if size changed
                                 when (bmDirty theBlockMap1) keepSyncingBlockMap)

-- |Writes the FSRoot to cache, then to device
syncFSRoot :: FSWrite ()
syncFSRoot = do
  putS "syncing... "
  FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet
  let syncBBC = syncBBCache cache
  assert (status == FsReadWrite) syncBBC
  syncDirectoryCache
  syncBBC
  syncInodeMapFile
  syncBBC
  syncBlockMapFile
  syncBBC
  syncInodeCache
 -- Have to do it twice; the first time it might actually change
 -- itself.  FIX: Should actually do this until we stabalize, and
 -- write the inode cache after each one!
--  syncBlockMapFile >> syncInodeCache
  keepSyncingBlockMap
  syncBBC


-- |Writes the FSRoot to cache (sans free list), then to device
shortSyncFSRoot :: FSWrite ()
shortSyncFSRoot = do
  putS "syncing (sans free list) ... "
  FSRoot{fsStatus=status, bbCache=cache} <- unsafeWriteGet
  let syncBBC = syncBBCache cache
  assert (status == FsReadWrite) $ return ()
  syncDirectoryCache
  syncInodeMapFile
  syncInodeCache
-- finally, the buffer blocks them selfs.
  syncBBC

putS :: String -> FSWrite ()
putS = putStrLnWriteRead