halfs-0.2: Halfs/FSState.hs

{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, RankNTypes, FlexibleContexts #-}

-- | Convenience module for exporting usually useful stuff
-- ALL "unsafe*" functions must be deleted and turned into "primitives"
-- in this module.

module Halfs.FSState (StateHandle(..) -- FIX: might get rid of FSState or StateHandle.
                      -- writing stuff:
                     ,FSWrite, unsafeLiftIOWrite, runFSWrite
                     ,evalFSWriteIO, evalFSWriteIOMV
                     ,runFSWriteIO, readToWrite, readToWriteCont, writeToBuffer
                     ,unsafeLiftIOWriteWithRoot, unsafeWriteGet, putStrLnWriteRead
                     ,updateInodeCacheWrite
                     ,modifyFSWrite
                      -- reading stuff:
                     ,FSRead, unsafeLiftIORead, runFSRead
                     ,runFSReadIO, evalFSReadIOMV, unsafeReadGet
                     ,unsafeModifyFSRead
                     ,unsafeWriteToRead
                      -- general monad capabilities. move elsewhere?
                     ,newReadRef, readReadRef, modifyReadRef, writeReadRef
                     ,takeMVarRW, readMVarRW, putMVarRW, modifyMVarRW_
                     ,modifyMVarRW_'
                      -- other stuff:
                     ,module Control.Monad.Trans
                     ,module Control.Monad.Error
                     ,module Control.Monad.State
                      -- read-write
                     ,FSRW, unsafeLiftIORW
                      -- FIX: don't export put & get:
                     ,Control.Monad.State.put
                     ,Control.Monad.State.get
                     ,alreadyExistsEx
                     ,doesNotExistEx
                     ,eofEx
                     ,illegalOpEx
                     ,decLinksForInode
                     ,forkWithMVar
                     ,forkFSWrite
               ) where

import Binary (Binary, BinHandle, put_)
import Halfs.FSRoot (FSRoot(..), FSStatus(..)
                    ,fsRootUpdateInodeCache)
import Halfs.FSRW
import Halfs.Inode(Inode(..), InodeMetadata(..))
-- import System.RawDevice(RawDevice)

-- FIX: get rid of FSState data type; we only need it because it works
-- on the StateT monad.  We can rool it ourselves and get rid of
-- FSState, probably.

-- base

import Control.Concurrent(MVar, ThreadId, modifyMVar_, tryPutMVar, modifyMVar,
                          putMVar, newMVar, readMVar, forkIO, takeMVar,
                          withMVar)
import Control.Exception(assert)
import Control.Monad.Error(throwError, catchError, MonadError)
import Control.Monad.State(StateT(..), modify,
                           evalStateT, execStateT,
                           MonadState)
import qualified Control.Monad.State (get, put)
import Control.Monad.Trans(liftIO)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef, writeIORef)
import System.IO.Error (alreadyExistsErrorType, doesNotExistErrorType,
                        illegalOperationErrorType, eofErrorType, mkIOError)

-- | Read-write state
data StateHandle
    = StateHandle { {- any function needing access to the FSRoot
                       needs to get this mvar: -}
                    stateFineMVar  :: MVar FSRoot

                    {- clients can use this MVar to block by calling
                       the evalFS{Read,Write}IOMV functions: -}
                  , stateCoarseMVar :: Maybe (MVar ())
                  } deriving Eq
type FSState a = StateT StateHandle IO a

alreadyExistsEx :: FilePath -> IOError
alreadyExistsEx path
    = mkIOError alreadyExistsErrorType "already exists" Nothing (Just path)

doesNotExistEx :: FilePath -> IOError
doesNotExistEx path
    = mkIOError doesNotExistErrorType "does not exist" Nothing (Just path)

illegalOpEx :: FilePath -> IOError
illegalOpEx path
    = mkIOError illegalOperationErrorType "illegal operation" Nothing (Just path)

eofEx :: FilePath -> IOError
eofEx path = mkIOError eofErrorType "EOF" Nothing (Just path)

-- ------------------------------------------------------------
-- * FSState Read Only
-- ------------------------------------------------------------

newtype FSRead a = FSR (FSState a)
instance Monad FSRead where
  return a = FSR (return a)
  (FSR m) >>= k  = FSR $ do a <- m
                            runFSRead $ k a

-- | Make this read-only monad into a read-write monad.
runFSRead :: FSRead a -> FSState a
runFSRead (FSR f) = f

-- | Returns the FSRoot since things like Inode cache may change.
runFSReadIO' :: FSRead a
             -> FSRoot
             -> IO (a, FSRoot)
runFSReadIO' (FSR f) s =
  do mv <- newMVar s
  -- same mvar, so ignore it on output:
     (r,_) <- runStateT f (StateHandle mv Nothing)
     fsroot <- readMVar mv
     return (r, fsroot)

runFSReadIO :: FSRead a
            -> FSRoot
            -> (IOError -> IO (a, FSRoot)) -- exception handler
            -> IO (a, FSRoot)
runFSReadIO f s handler = catch (runFSReadIO' f s) handler

-- |
evalFSReadIOMV :: FSRead a -> StateHandle -> IO a
evalFSReadIOMV (FSR f) mv@(StateHandle _ (Just blockOn))
    = do (r,_) <- withMVar blockOn $ \ _ -> runStateT f mv
         return r
evalFSReadIOMV (FSR f) mv@(StateHandle _ Nothing)
    = do (r,_) <- runStateT f mv
         return r

-- | Unsafe because it uses readMVar.
unsafeReadGet :: FSRead FSRoot
unsafeReadGet = FSR $ do (StateHandle mv _) <- Control.Monad.State.get
                         liftIO $ readMVar mv

-- | FIX: Unsafe?
unsafeModifyFSRead :: (FSRoot -> (FSRoot, a)) -> FSRead a
unsafeModifyFSRead f = FSR $ do
  (StateHandle mv _) <- Control.Monad.State.get
  retVal <- liftIO $ modifyMVar mv (\fsroot -> return (f fsroot))
  return retVal

-- | FIX: Delete this function; it's temporary during refactoring.  It
-- violates safety requirements.
unsafeLiftIORead :: IO a -> FSRead a
unsafeLiftIORead action = FSR $ liftIO action

-- | unsafe since this allows a reader to write.
unsafeWriteToRead :: FSWrite a -> FSRead a
unsafeWriteToRead (FSW a) = FSR a

-- These are mostly for handles.  The types aren't what we would like
-- since we can't import FileHandle.

-- This synonym is for documentation purposes:
type ReadRef a = IORef a

newReadRef :: a -> FSRead (ReadRef a)
newReadRef = unsafeLiftIORead . newIORef

readReadRef :: (ReadRef a) -> FSRead a
readReadRef = unsafeLiftIORead . readIORef

modifyReadRef :: (ReadRef a) -> (a -> a) -> FSRead ()
modifyReadRef f h = unsafeLiftIORead $ modifyIORef f h

writeReadRef :: (ReadRef a) -> a -> FSRead ()
writeReadRef f h = unsafeLiftIORead $ writeIORef f h

takeMVarRW :: (FSRW m) => MVar a -> m a
takeMVarRW = unsafeLiftIORW . takeMVar

putMVarRW :: (FSRW m) => MVar a -> a -> m ()
putMVarRW m a = unsafeLiftIORW (putMVar m a)

readMVarRW :: (FSRW m) => MVar a -> m a
readMVarRW = unsafeLiftIORW . readMVar

modifyMVarRW_ :: (FSRW m) => MVar a -> (a -> IO a) -> m ()
modifyMVarRW_ m f = unsafeLiftIORW (modifyMVar_ m f)

modifyMVarRW_' :: (FSRW m, MonadError IOError m) => MVar a -> (a -> m a) -> m ()
modifyMVarRW_' m f = do
  s <- takeMVarRW m
  catchError (f s >>= putMVarRW m)
             (\e -> putMVarRW m s >> unsafeLiftIORW (throwError e))

instance MonadError IOError FSRead where
    throwError = FSR . throwError
    catchError (FSR m) f
        = FSR $ catchError m (\e -> runFSRead $ f e)

-- ------------------------------------------------------------
-- * FSState Write Only
-- ------------------------------------------------------------

newtype FSWrite a = FSW (FSState a)
instance Monad FSWrite where
  return a = FSW (return a)
  (FSW m) >>= k  = FSW $ do a <- m
                            runFSWrite $ k a

-- | Make this write-only monad into a read-write monad.
runFSWrite :: FSWrite a -> FSState a
runFSWrite (FSW f) = f

-- Forks a new thread which uses the mvar from this state.  Whew.  Sorta doesn't make sense to be in FSWrite, maybe should just be in IO; we have two versions of the state available here, and that's no good... one is really just for syncronizeation.

forkWithMVar :: (StateHandle -> FSWrite ()) -> FSWrite ThreadId
forkWithMVar f = do
  mv <- FSW Control.Monad.State.get
  forkFSWrite (f mv)

forkFSWrite :: FSWrite () -> FSWrite ThreadId
forkFSWrite (FSW f) =
  FSW (do mv <- Control.Monad.State.get
          -- safe to ignore output since its held in the mvar
          liftIO $ forkIO $ (runStateT f mv >> return ()))

runFSWriteIO :: FSWrite a -> FSRoot -> IO (a, FSRoot)
runFSWriteIO (FSW f) s = do mv <- newMVar s
                            -- same mvar, so ignore it on output:
                            (r,_) <- runStateT f (StateHandle mv Nothing)
                            fsroot <- readMVar mv
                            return (r, fsroot)

evalFSWriteIOMV :: FSWrite a -> StateHandle -> IO a
evalFSWriteIOMV (FSW f) mv@(StateHandle _ (Just blockOn))
    = do (r,_) <- withMVar blockOn $ \ _ -> runStateT f mv
         return r
evalFSWriteIOMV (FSW f) mv@(StateHandle _ Nothing)
    = do (r,_) <- runStateT f mv
         return r

-- |
evalFSWriteIO :: FSWrite a -> FSRoot -> IO a
evalFSWriteIO (FSW f) s = do
  mv <- newMVar s
  evalStateT f (StateHandle mv Nothing)

putStrLnWriteRead :: String -> FSWrite ()
putStrLnWriteRead = unsafeLiftIOWrite . putStrLn

-- | FIX: Delete this function; it's temporary during refactoring.  It
-- violates safety requirements.
unsafeLiftIOWrite :: IO a -> FSWrite a
unsafeLiftIOWrite action = FSW $ liftIO action

unsafeLiftIOWriteWithRoot :: (FSRoot -> IO a) -> FSWrite a
unsafeLiftIOWriteWithRoot action = FSW $ do (StateHandle mv _) <- Control.Monad.State.get
                                            fsroot <- liftIO $ readMVar mv
                                            liftIO (action fsroot)

{- UNUSED:
-- | Blocks on the MVar while performing this action.
unsafeLiftIOWriteModifyRoot :: (FSRoot -> IO FSRoot) -> FSWrite ()
unsafeLiftIOWriteModifyRoot action
    = FSW $ do (StateHandle mv v)
                   <- Control.Monad.State.get
               _newRoot <- liftIO $ withMVar mv action
               -- unnecessary:
               Control.Monad.State.put (StateHandle mv v)
-}

writeToBuffer :: (Binary a) => BinHandle -> a -> FSWrite ()
writeToBuffer bh a = FSW $ liftIO (Binary.put_ bh a)

instance MonadError IOError FSWrite where
    throwError = FSW . throwError
    catchError (FSW m) f
        = FSW $ catchError m (\e -> runFSWrite $ f e)

instance MonadState FSRoot FSWrite where
    get = FSW (do (StateHandle mv _) <- Control.Monad.State.get
--                  liftIO $ readMVar mv)
--                  liftIO $ putStrLn "monadState get!"
                  fsroot <- liftIO $ takeMVar mv
                  return $ assert (fsStatus fsroot /= FsUnmounted) fsroot
{-
                  maybeRoot <- liftIO $ tryTakeMVar mv
                  case maybeRoot of
                   -- FIX: remove below when using multi-threads:
                   Nothing -> liftIO $ putStrLn "DEADLOCK GET" >> error "deadlock get"
                   Just a  -> return a
-}
                   )
    put s = FSW (do (StateHandle mv _) <- Control.Monad.State.get
                    maybeFoo <- liftIO $ tryPutMVar mv s
                    case maybeFoo of
                     True -> return ()
                     False -> liftIO $ putStrLn "DEADLOCK PUT" >> error "deadlock put"                )

-- | Unsafe since it uses readMVar.  For get-only situations, for
-- reading and not writing; no mvar block.
unsafeWriteGet :: FSWrite FSRoot
unsafeWriteGet = FSW $ do (StateHandle mv _) <- Control.Monad.State.get
                          liftIO $ readMVar mv

-- | FIX: This 'f' should probably be in the FSRW monad, since that doesn't have state.
modifyFSWrite :: (FSRoot -> FSWrite (FSRoot, a)) -> FSWrite a
modifyFSWrite f = do
  fsroot <- Control.Monad.State.get
  (newRoot, retVal) <- f fsroot
  Control.Monad.State.put newRoot
  return retVal

-- | Safe since writers can be readers.
readToWrite :: FSRead a -> FSWrite a
readToWrite (FSR a) = FSW a

-- | Safe since writers can be readers.
readToWriteCont :: ((forall s . m s -> FSRead a) -> FSRead a)
                -> (forall s . m s -> FSWrite a) -> FSWrite a
readToWriteCont f cont =
  case f (w2r cont) of
     FSR a -> FSW a
  where
   w2r :: (forall s . m s -> FSWrite a) -> (forall s . m s -> FSRead a)
   w2r g s = case g s of
               FSW a -> FSR a



updateInodeCacheWrite :: Inode -> FSWrite ()
updateInodeCacheWrite inode
    = modify (\f -> fsRootUpdateInodeCache f inode)

decLinksForInode :: Inode -> FSWrite ()
decLinksForInode inode@Inode{metaData=md@InodeMetadata{hard_links=hl}}
    = updateInodeCacheWrite inode{metaData=md{hard_links=hl-1}}

-- ------------------------------------------------------------
-- * FSReadWrite
-- ------------------------------------------------------------

-- FSRW functions don't carry state unless it's passed explicitly as
-- input and output.
instance FSRW FSRead where
    unsafeLiftIORW = unsafeLiftIORead

instance FSRW FSWrite where
    unsafeLiftIORW = unsafeLiftIOWrite