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