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 qualified Data.Set as S
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 </> "index"
             revFile  = lsdir </> "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 -> Maybe RevNum -> m (Maybe Page)
getPage = ((liftIO .) .) . getPage' . stoRepository


getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
getPage' repos name rev
    = loadDefaultPage name -- FIXME


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


getPageA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) (Maybe Page)
getPageA = arrIO2 . getPage 


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


findAllPages :: Storage -> RevNum -> IO (Set PageName)
findAllPages _   0   = findAllDefaultPages
findAllPages sto rev
    = 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 newRev
    where
      syncIndex' :: RevNum -> RevNum -> IO ()
      syncIndex' oldRev newRev
          = do pages <- findChangedPages sto oldRev newRev
               mapM_ (updateIndex sto newRev) (S.toList pages)


updateIndex :: Storage -> RevNum -> PageName -> IO ()
updateIndex sto rev name
    = do pageM <- getPage sto name (Just rev)
         case pageM of
           -- ページが削除された
           Nothing
               -> do docIdM <- getDocIdByURI (stoIndexDB sto) (mkRakkaURI name)
                     case docIdM of
                       Nothing    -> return ()
                       Just docId -> do removeDocument (stoIndexDB sto) docId [CleaningRemove]
                                        infoM logger ("Removed page " ++ name ++ " from the index")
           Just page
               -> do draft <- stoMakeDraft sto page
                     putDocument (stoIndexDB sto) draft [CleaningPut]
                     infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))


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")