Rakka/Storage.hs

   1 module Rakka.Storage
   2     ( Storage
   3
   4     , mkStorage -- private
   5
   6     , getPage
   7     , putPage
   8
   9     , getPageA
  10     , putPageA
  11     )
  12     where
  13
  14 import           Control.Arrow.ArrowIO
  15 import           Control.Concurrent.STM
  16 import           Control.Exception
  17 import           Control.Monad
  18 import           Control.Monad.Trans
  19 import           Data.Set (Set)
  20 import           Rakka.Page
  21 import           Rakka.Storage.DefaultPage
  22 import           Subversion.Types
  23 import           System.Directory
  24 import           System.FilePath
  25 import           System.IO
  26 import           System.Log.Logger
  27 import           System.Posix.Files
  28 import           System.Posix.Types
  29 import           System.Posix.IO
  30 import           Subversion.FileSystem
  31 import           Subversion.Repository
  32 import           Text.HyperEstraier hiding (WriteLock)
  33
  34 logger = "Rakka.Storage"
  35
  36
  37 data Storage
  38     = Storage {
  39         stoIndexRevLocked :: !(TVar Bool)
  40       , stoIndexRevFile   :: !FilePath
  41       , stoIndexDB        :: !Database
  42       , stoRepository     :: !Repository
  43       , stoMakeDraft      :: !(Page -> IO Document)
  44       }
  45
  46
  47 mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
  48 mkStorage lsdir repos mkDraft
  49     = do let indexDir = lsdir `combine` "index"
  50              revFile  = lsdir `combine` "indexRev"
  51
  52          revLocked <- newTVarIO False
  53          indexDB   <- openIndex indexDir revFile
  54
  55          let sto = Storage {
  56                      stoIndexRevLocked = revLocked
  57                    , stoIndexRevFile   = revFile
  58                    , stoIndexDB        = indexDB
  59                    , stoRepository     = repos
  60                    , stoMakeDraft      = mkDraft
  61                    }
  62
  63          syncIndex sto
  64          return sto
  65
  66
  67 getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page)
  68 getPage sto name
  69     = liftIO $ loadDefaultPage name -- FIXME
  70
  71
  72 putPage :: MonadIO m => Storage -> Maybe RevNum -> Page -> m ()
  73 putPage sto oldRev page
  74     = error "FIXME: not implemented"
  75
  76
  77 getPageA :: ArrowIO a => Storage -> a PageName (Maybe Page)
  78 getPageA = arrIO . getPage
  79
  80
  81 putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) ()
  82 putPageA = arrIO2 . putPage
  83
  84
  85 findAllPages :: Storage -> RevNum -> IO (Set PageName)
  86 findAllPages sto revNum
  87     = findAllDefaultPages -- FIXME
  88
  89
  90 findChangedPages :: Storage -> RevNum -> RevNum -> IO (Set PageName)
  91 findChangedPages sto 0      newRev = findAllPages sto newRev
  92 findChangedPages sto oldRev newRev
  93     = fail "fixme: not impl"
  94
  95
  96 getCurrentRevNum :: Storage -> IO RevNum
  97 getCurrentRevNum sto
  98     = getRepositoryFS (stoRepository sto) >>= getYoungestRev
  99
 100
 101 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
 102 -- indexDir と revFile を削除してから casket を R/W モードで開く。
 103 openIndex :: FilePath -> FilePath -> IO Database
 104 openIndex indexDir revFile
 105     = do ret <- openDatabase indexDir (Writer [])
 106          case ret of
 107            Right db
 108                -> do debugM logger ("Opened an H.E. database on " ++ indexDir)
 109                      return db
 110
 111            Left err
 112                -> do warningM logger ("Failed to open an H.E. database on "
 113                                       ++ indexDir ++ ": " ++ show err)
 114
 115                      indexExists <- doesDirectoryExist indexDir
 116                      when indexExists
 117                               $ removeDirectoryRecursive indexDir
 118
 119                      revFileExists <- doesFileExist revFile
 120                      when revFileExists
 121                               $ removeFile revFile
 122
 123                      Right db <- openDatabase indexDir (Writer [Create []])
 124                      noticeM logger ("Created an H.E. database on " ++ indexDir)
 125
 126                      return db
 127
 128
 129 syncIndex :: Storage -> IO ()
 130 syncIndex sto
 131     = updateIndexRev sto $ \ oldRev ->
 132       do debugM logger ("The index revision is currently " ++ show oldRev)
 133
 134          newRev <- getCurrentRevNum sto
 135          debugM logger ("The repository revision is currently " ++ show newRev)
 136
 137          when (newRev /= oldRev) (syncIndex' oldRev newRev)
 138
 139          return oldRev -- FIXME
 140     where
 141       syncIndex' :: RevNum -> RevNum -> IO ()
 142       syncIndex' oldRev newRev
 143           = do pages <- findChangedPages sto oldRev newRev
 144                print pages
 145
 146
 147 updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO ()
 148 updateIndexRev sto f = bracket acquireLock releaseLock update
 149     where
 150       acquireLock :: IO Fd
 151       acquireLock
 152           = do atomically $ do revLocked <- readTVar (stoIndexRevLocked sto)
 153                                if revLocked then
 154                                    retry
 155                                  else
 156                                    writeTVar (stoIndexRevLocked sto) True
 157                fd <- openFd (stoIndexRevFile sto) ReadWrite (Just stdFileMode) defaultFileFlags
 158                waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
 159                return fd
 160
 161       releaseLock :: Fd -> IO ()
 162       releaseLock fd
 163           = do setLock fd (Unlock, AbsoluteSeek, 0, 0)
 164                atomically $ writeTVar (stoIndexRevLocked sto) False
 165
 166       update :: Fd -> IO ()
 167       update fd
 168           = do fdSeek fd AbsoluteSeek 0
 169                size <- return . fromIntegral . fileSize =<< getFdStatus fd
 170                (revStr, gotSize) <- fdRead fd size
 171                when (size /= gotSize) $ fail ("read " ++ show gotSize ++
 172                                               " bytes but expected " ++ show size ++ " bytes")
 173
 174                let rev = case revStr of
 175                            "" -> 0
 176                            _  -> read revStr
 177
 178                rev' <- f rev
 179
 180                let revStr' = show rev' ++ "\n"
 181                    size'   = fromIntegral $ length revStr'
 182
 183                fdSeek fd AbsoluteSeek 0
 184                setFdSize fd 0
 185                wroteSize <- fdWrite fd revStr'
 186                when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
 187                                                  " bytes but expected " ++ show size' ++ " bytes")