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 </> "index"
  50              revFile  = lsdir </> "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          --return newRev
 141     where
 142       syncIndex' :: RevNum -> RevNum -> IO ()
 143       syncIndex' oldRev newRev
 144           = do pages <- findChangedPages sto oldRev newRev
 145                print pages -- FIXME
 146
 147
 148 updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO ()
 149 updateIndexRev sto f = bracket acquireLock releaseLock update
 150     where
 151       acquireLock :: IO Fd
 152       acquireLock
 153           = do atomically $ do revLocked <- readTVar (stoIndexRevLocked sto)
 154                                if revLocked then
 155                                    retry
 156                                  else
 157                                    writeTVar (stoIndexRevLocked sto) True
 158                fd <- openFd (stoIndexRevFile sto) ReadWrite (Just stdFileMode) defaultFileFlags
 159                waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
 160                return fd
 161
 162       releaseLock :: Fd -> IO ()
 163       releaseLock fd
 164           = do setLock fd (Unlock, AbsoluteSeek, 0, 0)
 165                atomically $ writeTVar (stoIndexRevLocked sto) False
 166
 167       update :: Fd -> IO ()
 168       update fd
 169           = do fdSeek fd AbsoluteSeek 0
 170                size <- return . fromIntegral . fileSize =<< getFdStatus fd
 171                (revStr, gotSize) <- fdRead fd size
 172                when (size /= gotSize) $ fail ("read " ++ show gotSize ++
 173                                               " bytes but expected " ++ show size ++ " bytes")
 174
 175                let rev = case revStr of
 176                            "" -> 0
 177                            _  -> read revStr
 178
 179                rev' <- f rev
 180
 181                let revStr' = show rev' ++ "\n"
 182                    size'   = fromIntegral $ length revStr'
 183
 184                fdSeek fd AbsoluteSeek 0
 185                setFdSize fd 0
 186                wroteSize <- fdWrite fd revStr'
 187                when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
 188                                                  " bytes but expected " ++ show size' ++ " bytes")