module Rakka.Storage
    ( Storage

    , mkStorage -- private

    , getPage
    , putPage

    , getPageA
    , putPageA
    )
    where

import           Control.Arrow.ArrowIO
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import           Control.Monad.Trans
import           Data.Set (Set)
import           Rakka.Page
import           Rakka.Storage.DefaultPage
import           Subversion.Types
import           System.Directory
import           System.FilePath
import           System.IO
import           System.Log.Logger
import           System.Posix.Files
import           System.Posix.Types
import           System.Posix.IO
import           Subversion.FileSystem
import           Subversion.Repository
import           Text.HyperEstraier hiding (WriteLock)

logger = "Rakka.Storage"


data Storage
    = Storage {
        stoIndexRevLocked :: !(TVar Bool)
      , stoIndexRevFile   :: !FilePath
      , stoIndexDB        :: !Database
      , stoRepository     :: !Repository
      , stoMakeDraft      :: !(Page -> IO Document)
      }


mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
mkStorage lsdir repos mkDraft
    = do let indexDir = lsdir `combine` "index"
             revFile  = lsdir `combine` "indexRev"
             
         revLocked <- newTVarIO False
         indexDB   <- openIndex indexDir revFile

         let sto = Storage {
                     stoIndexRevLocked = revLocked
                   , stoIndexRevFile   = revFile
                   , stoIndexDB        = indexDB
                   , stoRepository     = repos
                   , stoMakeDraft      = mkDraft
                   }

         syncIndex sto
         return sto


getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page)
getPage sto name
    = liftIO $ loadDefaultPage name -- FIXME


putPage :: MonadIO m => Storage -> Maybe RevNum -> Page -> m ()
putPage sto oldRev page
    = error "FIXME: not implemented"


getPageA :: ArrowIO a => Storage -> a PageName (Maybe Page)
getPageA = arrIO . getPage 


putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) ()
putPageA = arrIO2 . putPage


findAllPages :: Storage -> RevNum -> IO (Set PageName)
findAllPages sto revNum
    = findAllDefaultPages -- FIXME


findChangedPages :: Storage -> RevNum -> RevNum -> IO (Set PageName)
findChangedPages sto 0      newRev = findAllPages sto newRev
findChangedPages sto oldRev newRev
    = fail "fixme: not impl"


getCurrentRevNum :: Storage -> IO RevNum
getCurrentRevNum sto
    = getRepositoryFS (stoRepository sto) >>= getYoungestRev


-- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
-- indexDir と revFile を削除してから casket を R/W モードで開く。
openIndex :: FilePath -> FilePath -> IO Database
openIndex indexDir revFile
    = do ret <- openDatabase indexDir (Writer [])
         case ret of
           Right db
               -> do debugM logger ("Opened an H.E. database on " ++ indexDir)
                     return db

           Left err
               -> do warningM logger ("Failed to open an H.E. database on "
                                      ++ indexDir ++ ": " ++ show err)

                     indexExists <- doesDirectoryExist indexDir
                     when indexExists
                              $ removeDirectoryRecursive indexDir

                     revFileExists <- doesFileExist revFile
                     when revFileExists
                              $ removeFile revFile

                     Right db <- openDatabase indexDir (Writer [Create []])
                     noticeM logger ("Created an H.E. database on " ++ indexDir)

                     return db


syncIndex :: Storage -> IO ()
syncIndex sto
    = updateIndexRev sto $ \ oldRev ->
      do debugM logger ("The index revision is currently " ++ show oldRev)
         
         newRev <- getCurrentRevNum sto
         debugM logger ("The repository revision is currently " ++ show newRev)

         when (newRev /= oldRev) (syncIndex' oldRev newRev)

         return oldRev -- FIXME
    where
      syncIndex' :: RevNum -> RevNum -> IO ()
      syncIndex' oldRev newRev
          = do pages <- findChangedPages sto oldRev newRev
               print pages


updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO ()
updateIndexRev sto f = bracket acquireLock releaseLock update
    where
      acquireLock :: IO Fd
      acquireLock
          = do atomically $ do revLocked <- readTVar (stoIndexRevLocked sto)
                               if revLocked then
                                   retry
                                 else
                                   writeTVar (stoIndexRevLocked sto) True
               fd <- openFd (stoIndexRevFile sto) ReadWrite (Just stdFileMode) defaultFileFlags
               waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
               return fd

      releaseLock :: Fd -> IO ()
      releaseLock fd
          = do setLock fd (Unlock, AbsoluteSeek, 0, 0)
               atomically $ writeTVar (stoIndexRevLocked sto) False

      update :: Fd -> IO ()
      update fd
          = do fdSeek fd AbsoluteSeek 0
               size <- return . fromIntegral . fileSize =<< getFdStatus fd
               (revStr, gotSize) <- fdRead fd size
               when (size /= gotSize) $ fail ("read " ++ show gotSize ++
                                              " bytes but expected " ++ show size ++ " bytes")
               
               let rev = case revStr of
                           "" -> 0
                           _  -> read revStr

               rev' <- f rev

               let revStr' = show rev' ++ "\n"
                   size'   = fromIntegral $ length revStr'

               fdSeek fd AbsoluteSeek 0
               setFdSize fd 0
               wroteSize <- fdWrite fd revStr'
               when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
                                                 " bytes but expected " ++ show size' ++ " bytes")