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.Monad
  17 import           Control.Monad.Trans
  18 import           Data.Set (Set)
  19 import           Rakka.Page
  20 import           Rakka.Storage.DefaultPage
  21 import           Subversion.Types
  22 import           System.Directory
  23 import           System.FilePath
  24 import           System.Log.Logger
  25 import           Subversion.Repository
  26 import           Text.HyperEstraier
  27
  28 -- FIXME
  29 import Data.Encoding
  30 import Data.Encoding.UTF8
  31 import qualified Data.ByteString.Lazy.Char8 as C8
  32 -- FIXME
  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 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
  91 -- indexDir と revFile を削除してから casket を R/W モードで開く。
  92 openIndex :: FilePath -> FilePath -> IO Database
  93 openIndex indexDir revFile
  94     = do ret <- openDatabase indexDir (Writer [])
  95          case ret of
  96            Right db
  97                -> do debugM logger ("Opened an H.E. database on " ++ indexDir)
  98                      return db
  99
 100            Left err
 101                -> do warningM logger ("Failed to open an H.E. database on "
 102                                       ++ indexDir ++ ": " ++ show err)
 103
 104                      indexExists <- doesDirectoryExist indexDir
 105                      when indexExists
 106                               $ removeDirectoryRecursive indexDir
 107
 108                      revFileExists <- doesFileExist revFile
 109                      when revFileExists
 110                               $ removeFile revFile
 111
 112                      Right db <- openDatabase indexDir (Writer [Create []])
 113                      noticeM logger ("Created an H.E. database on " ++ indexDir)
 114
 115                      return db
 116
 117
 118 syncIndex :: Storage -> IO ()
 119 syncIndex sto
 120     = do Just page <- getPage sto "MainPage"
 121          doc       <- stoMakeDraft sto page
 122          putStrLn "*** dumping draft..."
 123          dumpDraft doc >>= C8.putStr . encodeLazy UTF8
 124          putStrLn "*** dumped"