{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, Trustworthy #-}

-- | Some utility functions. The reader strategies maintain the invariant that the stream is seeked
--   to the beginning of a data entity, so that it is safe to use 'readData'/'writeData'/'seekTo'
--   etc. The writer strategies maintain the invariant that the writer is seeked at the word
--   that should receive the address of the data entity that is written. This allows the writer
--   to write eagerly the address and so be tail recursive in some cases.
--
--   Think of a columbia file as just a transactional log that is continually being
--   written to; transactions are able to reference other transactions by address, thus
--   constructing data structures; a single address, called the root node address, at the
--   beginning of the file determines the file's nominal mutable state. To keep the file from getting
--   too large, it is garbage collected periodically; calls to the
--   collector have to be programmed to happen manually at a time convenient for your
--   application.
--
--   Please be aware that while you *can* write new addresses over old in the file,
--   this is not compatible with the locking scheme, which is predicated on
--   the assumption that all writing happens to the root block address and appending to
--   the end of the file.
module Data.Columbia.Utils (rwProxy, readFileWrapper, writeFileWrapper) where

import Data.Word
import Data.IORef
import System.IO
import System.FileLock
import Control.Monad.Reader
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.IO.Class
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Context
import Data.Columbia.Types
import Data.Columbia.Internal.SeekableWriter
import Data.Columbia.Internal.SeekableStream
import Data.Columbia.Internal.Headers
import Data.Columbia.Internal.IntegralTypes
import Data.Columbia.Internal.DualLock
import Data.Columbia.Internal.Mapper

bracket m f f2 = do
	x <-m
	x2 <-catchError(f2 x) (\e->do { f x; throwError e })
	f x
	return x2

withFileLock' path mode = bracket
	(liftIO$lockFile path mode)
	(liftIO.unlockFile)

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

{-# INLINE seekToStart #-}
seekToStart :: (Monad m) => ReaderT(SeekableStream m Word8) m ()
seekToStart = seek 0

rwProxy :: Proxy(PairCtx RWCtx NoCtx)
rwProxy = error"proxy"

{-# INLINE snd3 #-}
snd3(_,x,_) = x

-- | A wrapper for reading Columbia files; the 'proc' parameter is a reading operation.
--   Use 'fixT' to make the conversion between 'PolyTraveral's and recursive reading
--   operations. Typically set 'm' parameter to 'IO'.
readFileWrapper :: (MonadError e m, MonadIO m)
	=> FilePath
	-> ReaderT(SeekableStream m Word8) m t
	-> m t
readFileWrapper path proc = liftIO(newIORef undefined)>>= \cursor->
	bracket
	(liftIO$dualLockShared path)
	(liftIO.unlockShared)
	$ \l@(DualLockShared _ _ l2) ->
	bracket
	(liftIO$makeIoWriter' path l2 True)
	(liftIO.snd3) -- Call delegate.
	$ \(writer,_,_) ->
	do
	let s = stream$hoistWriter liftIO writer
	-- Unlock the writer lock once having retrieved the root block address.
	withFileLock'(path++".lock.writer") Exclusive$ \_->runReaderT seekToStart s
	runReaderT proc s

-- | A wrapper for writing Columbia files; 'fixTW' converts between 'PolyTraversalW's
--   and recursive writing operations.
writeFileWrapper :: (MonadError e m, MonadIO m)
	=> FilePath
	-> ReaderT(SeekableWriter m Word8) m t
	-> m t
writeFileWrapper path proc = liftIO(newIORef undefined)>>= \cursor->
	bracket
	(liftIO$dualLockShared path)
	(liftIO.unlockShared)
	$ \_->
	withFileLock'(path++".lock.writer") Exclusive
	$ \l ->
	bracket
	(liftIO$makeIoWriter' path l True)
	(liftIO.snd3)
	$ \(writer,_,_) ->
	let writer' = hoistWriter liftIO writer in
	runReaderT
	(do
		sw <- ask
		seekWriterAtEnd
		len <- getWriterPosition
		addr::Pointer <- if len==0 then do
			writeIntegral(0 :: Pointer)
			return$!0
			else do
		-- For robustness in case of power failures etc. I will special case the root block pointer
		-- so it writes into a slop field. Once writing is complete, the slop field is copied into
		-- the actual root block pointer field. That way an interruption to the writing procedure
		-- does no harm to the file and leaves it in its previous nominal state.
			seekWriter 0
			local' stream readIntegral
		seekWriterAtEnd
		-- Create slop field.
		writeHeader rwProxy(0::Pointer)
		len2 <- getWriterPosition
		writeIntegral addr
		seekWriter len2
		x <- proc
		-- Copy address into root block address field.
		seekWriter len2
		n::Pointer <- local' stream readIntegral
		seekWriter 0
		writeIntegral n
		return x
	)
	writer'