{-# 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; in other words it is predicated on all data being immutable
--   except the root block address. In order to do that, you will have to use your own
--   locking scheme to make that work.
module Data.Columbia.Utils (rwProxy, readFileWrapper, writeFileWrapper, nFields) 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.Headers
import Data.Columbia.Integral
import Data.Columbia.CompoundData
import Data.Columbia.DualLock
import Data.Columbia.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 = undefined

-- | Opens a file for reading, under appropriate locks; seeks to the beginning of the data;
--   runs the procedure. For common use, set m := 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$newTable path)
	(liftIO.concludeFileWrite cursor)
	$ \table ->
	do
	liftIO$do
		sz <-fileSizeShim table
		writeIORef cursor$!(0,sz)
	let stream = hoistStream liftIO$makeIoStream cursor table l2
	-- Unlock the writer lock once having retrieved the root block address.
	withFileLock'(path++".lock.writer") Exclusive$ \_->runReaderT seekToStart stream
	runReaderT proc stream

-- | Opens a file for /writing/, under appropriate locks; seeks to the beginning of the data;
--   runs the procedure; accepts from the procedure an address to write as the new
--   root node address.
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$newTable path)
	(liftIO.concludeFileWrite cursor)
	$ \table ->
	let writer = hoistWriter liftIO$makeIoWriter cursor table l in
	runReaderT
	(do
		liftIO$do
			sz <-fileSizeShim table
			writeIORef cursor$!(0,sz)
		sw <- ask
		seekWriterAtEnd
		len <- getWriterPosition
		addr::Word32 <- if len==0 then do
			writeIntegral(0 :: Word32)
			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::Word32 <- local' stream readIntegral
		seekWriter 0
		writeIntegral n
		return x
	)
	writer

nFields hdr@(_, _, nFields) = if isHeaderArraytype hdr then do
		readIntegral
	else
		return nFields