module Database.VCache.Open
    ( openVCache
    ) where

import Control.Monad
import Control.Exception
import System.FileLock (FileLock)
import qualified System.FileLock as FileLock
import qualified System.EasyFile as EasyFile
import qualified System.IO.Error as IOE
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Ptr

import Data.Bits
import Data.IORef
import Data.Maybe
import qualified Data.Map.Strict as Map
import qualified Data.ByteString as BS
import qualified Data.List as L
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Control.Concurrent

import qualified System.IO as Sys
import qualified System.Exit as Sys

import Database.LMDB.Raw
import Database.VCache.Types 
import Database.VCache.RWLock
import Database.VCache.Aligned
import Database.VCache.Write
import Database.VCache.Clean 



-- | Open a VCache with a given database file. 
--
-- In most cases, a Haskell process should open VCache in the Main
-- module then pass it as an argument to the different libraries,
-- frameworks, plugins, and other software components that require
-- persistent storage. Use vcacheSubdir to progect against namespace
-- collisions. 
--
-- When opening VCache, developers decide the maximum size and the file
-- name. For example:
--
-- > vc <- openVCache 100 "db"
--
-- This would open a VCache whose file-size limit is 100 megabytes, 
-- with the name "db", plus an additional "db-lock" lockfile. An 
-- exception will be raised if these files cannot be created, locked,
-- or opened. The size limit is passed to LMDB and is separate from
-- setVRefsCacheSize. 
--
-- Once opened, VCache typically remains open until process halt. 
-- If errors are detected, e.g. due to writing an undefined value
-- to a PVar or running out of space, VCache will attempt to halt
-- the process.
--
openVCache :: Int -> FilePath -> IO VCache
openVCache nMB fp = do
    let (fdir,fn) = EasyFile.splitFileName fp
    let eBadFile = fp ++ " not recognized as a file name"
    when (L.null fn) (fail $ "openVCache: " ++ eBadFile)
    EasyFile.createDirectoryIfMissing True fdir
    let fpLock = fp ++ "-lock"
    let nBytes = (max 1 nMB) * 1024 * 1024
    mbLock <- FileLock.tryLockFile fpLock FileLock.Exclusive 
    case mbLock of
        Nothing -> ioError $ IOE.mkIOError
            IOE.alreadyInUseErrorType
            "openVCache lockfile"
            Nothing (Just fpLock)
        Just fl -> openVC' nBytes fl fp 
                    `onException` FileLock.unlockFile fl

vcFlags :: [MDB_EnvFlag] 
vcFlags = [MDB_NOSUBDIR     -- open file name, not directory name
          ,MDB_NOLOCK       -- leave lock management to VCache
          ]

--
-- I'm providing a non-empty root bytestring. There are a few reasons
-- for this. LMDB doesn't support zero-sized keys. And the empty
-- bytestring will indicate anonymous PVars in the allocator. And if
-- I ever want PVar roots within VCache, I can use a different prefix.
--
-- The maximum path, including the PVar name, is 511 bytes. That is
-- enough for almost any use case, especially since roots should not
-- depend on domain data. Too large a path results in runtime error.
vcRootPath :: BS.ByteString
vcRootPath = BS.singleton 47

-- Default address for allocation. We start this high to help 
-- regulate serialization sizes and simplify debugging.
vcAllocStart :: Address 
vcAllocStart = 999999999

-- Default cache size is somewhat arbitrary. I've chosen to set it
-- to about ten megabytes (as documented in the Cache module). 
vcDefaultCacheLimit :: Int
vcDefaultCacheLimit = 10 * 1000 * 1000 

-- initial cache size
vcInitCacheSizeEst :: CacheSizeEst
vcInitCacheSizeEst = CacheSizeEst
    { csze_addr_size = sz -- err likely on high side to start
    , csze_addr_sqsz = (sz * sz)
    }
    where sz = 2048 -- err likely on high side to start

-- Checking for a `-threaded` runtime
threaded :: Bool
threaded = rtsSupportsBoundThreads

openVC' :: Int -> FileLock -> FilePath -> IO VCache
openVC' nBytes fl fp = do
    
    unless threaded (fail "VCache needs -threaded runtime")

    dbEnv <- mdb_env_create
    mdb_env_set_mapsize dbEnv nBytes
    mdb_env_set_maxdbs dbEnv 5
    mdb_env_open dbEnv fp vcFlags
    flip onException (mdb_env_close dbEnv) $ do

        -- initial transaction to grab database handles and init allocator
        txnInit <- mdb_txn_begin dbEnv Nothing False
        dbiMemory <- mdb_dbi_open' txnInit (Just "@") [MDB_CREATE, MDB_INTEGERKEY]
        dbiRoots  <- mdb_dbi_open' txnInit (Just "/") [MDB_CREATE]
        dbiHashes <- mdb_dbi_open' txnInit (Just "#") [MDB_CREATE, MDB_INTEGERKEY, MDB_DUPSORT, MDB_DUPFIXED, MDB_INTEGERDUP]
        dbiRefct  <- mdb_dbi_open' txnInit (Just "^") [MDB_CREATE, MDB_INTEGERKEY]
        dbiRefct0 <- mdb_dbi_open' txnInit (Just "%") [MDB_CREATE, MDB_INTEGERKEY]
        allocEnd <- findLastAddrAllocated txnInit dbiMemory
        mdb_txn_commit txnInit

        -- ephemeral resources
        let allocStart = nextAllocAddress allocEnd
        memory <- newMVar (initMemory allocStart)
        tvWrites <- newTVarIO (Writes Map.empty [])
        mvSignal <- newMVar ()
        cLimit <- newIORef vcDefaultCacheLimit
        cSize <- newIORef vcInitCacheSizeEst
        cVRefs <- newMVar Map.empty
        ctWrites <- newIORef $ WriteCt 0 0 0
        gcStart <- newIORef Nothing
        gcCount <- newIORef 0
        rwLock <- newRWLock

        -- finalizer, in unlikely event of closure
        _ <- mkWeakMVar mvSignal $ do
                mdb_env_close dbEnv
                FileLock.unlockFile fl

        let vc = VCache 
                { vcache_path = vcRootPath
                , vcache_space = VSpace 
                    { vcache_lockfile = fl
                    , vcache_db_env = dbEnv
                    , vcache_db_memory = dbiMemory
                    , vcache_db_vroots = dbiRoots
                    , vcache_db_caddrs = dbiHashes
                    , vcache_db_refcts = dbiRefct
                    , vcache_db_refct0 = dbiRefct0
                    , vcache_memory = memory
                    , vcache_signal = mvSignal
                    , vcache_writes = tvWrites
                    , vcache_rwlock = rwLock
                    , vcache_climit = cLimit
                    , vcache_csize = cSize
                    , vcache_cvrefs = cVRefs
                    , vcache_signal_writes = updWriteCt ctWrites
                    , vcache_ct_writes = ctWrites
                    , vcache_alloc_init = allocStart
                    , vcache_gc_start = gcStart
                    , vcache_gc_count = gcCount
                    }
                }

        initVCacheThreads (vcache_space vc)
        return $! vc

-- our allocator should be set for the next *even* address.
nextAllocAddress :: Address -> Address
nextAllocAddress addr | (0 == (addr .&. 1)) = 2 + addr
                      | otherwise           = 1 + addr

-- Determine the last VCache VRef address allocated, based on the
-- actual database contents. If nothing is
findLastAddrAllocated :: MDB_txn -> MDB_dbi' -> IO Address
findLastAddrAllocated txn dbiMemory = alloca $ \ pKey ->
    mdb_cursor_open' txn dbiMemory >>= \ crs ->
    mdb_cursor_get' MDB_LAST crs pKey nullPtr >>= \ bFound ->
    mdb_cursor_close' crs >>
    if (not bFound) then return vcAllocStart else 
    peek pKey >>= \ key -> 
    let bBadSize = fromIntegral (sizeOf vcAllocStart) /= mv_size key in 
    if bBadSize then fail "VCache memory table corrupted" else
    peekAligned (castPtr (mv_data key)) 

-- initialize memory based on initial allocation position
initMemory :: Address -> Memory
initMemory addr = m0 where
    af = AllocFrame Map.empty Map.empty addr
    ac = Allocator addr af af af
    gcf = GCFrame Map.empty
    gc = GC gcf gcf
    m0 = Memory Map.empty Map.empty gc ac

-- Update write counts.
updWriteCt :: IORef WriteCt -> Writes -> IO ()
updWriteCt var w = modifyIORef' var $ \ wct ->
    let frmCt = 1 + wct_frames wct in
    let pvCt = wct_pvars wct + Map.size (write_data w) in
    let synCt = wct_sync wct + L.length (write_sync w) in
    WriteCt { wct_frames = frmCt, wct_pvars = pvCt, wct_sync = synCt }

-- | Create background threads needed by VCache.
initVCacheThreads :: VSpace -> IO ()
initVCacheThreads vc = begin where
    begin = do
        task (writeStep vc)
        task (cleanStep vc)
        return ()
    task step = void (forkIO (forever step `catch` onE))
    onE :: SomeException -> IO ()
    onE e | isBlockedOnMVar e = return () -- full GC of VCache
    onE e = do
        putErrLn "VCache background thread has failed."
        putErrLn (indent "  " (show e))
        putErrLn "Halting program."
        Sys.exitFailure

isBlockedOnMVar :: (Exception e) => e -> Bool
isBlockedOnMVar = isJust . test . toException where
    test :: SomeException -> Maybe BlockedIndefinitelyOnMVar
    test = fromException

putErrLn :: String -> IO ()
putErrLn = Sys.hPutStrLn Sys.stderr

indent :: String -> String -> String
indent ws = (ws ++) . indent' where
    indent' ('\n':s) = '\n' : ws ++ indent' s
    indent' (c:s) = c : indent' s
    indent' [] = []