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     , searchPages
  13
  14     , rebuildIndex
  15     )
  16     where
  17
  18 import           Control.Arrow.ArrowIO
  19 import           Control.Concurrent.STM
  20 import           Control.Monad
  21 import           Control.Monad.Trans
  22 import           Data.Maybe
  23 import           Network.HTTP.Lucu
  24 import           Rakka.Page
  25 import           Rakka.Storage.Impl
  26 import           Rakka.Storage.Types
  27 import           Subversion.Types
  28 import           System.IO
  29 import           Subversion.Repository
  30 import           Text.HyperEstraier hiding (WriteLock)
  31
  32
  33 mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
  34 mkStorage lsdir repos mkDraft
  35     = do chan <- startIndexManager lsdir repos mkDraft
  36          let sto = Storage {
  37                      stoRepository = repos
  38                    , stoIndexChan  = chan
  39                    }
  40          syncIndex sto
  41          return sto
  42
  43
  44 getPage :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m (Maybe Page)
  45 getPage = ((liftIO .) .) . getPage' . stoRepository
  46
  47
  48 putPage :: MonadIO m => Storage -> Page -> m StatusCode
  49 putPage sto page
  50     = liftIO $ do st <- putPage' (stoRepository sto) page
  51                   syncIndex sto
  52                   return st
  53
  54
  55 getPageA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) (Maybe Page)
  56 getPageA = arrIO2 . getPage
  57
  58
  59 putPageA :: ArrowIO a => Storage -> a Page StatusCode
  60 putPageA = arrIO . putPage
  61
  62
  63 searchPages :: MonadIO m => Storage -> Condition -> m [(PageName, RevNum)]
  64 searchPages sto cond
  65     = liftIO $
  66       do var <- newEmptyTMVarIO
  67          atomically $ writeTChan (stoIndexChan sto) (SearchIndex cond var)
  68          atomically $ takeTMVar var
  69
  70
  71 rebuildIndex :: MonadIO m => Storage -> m ()
  72 rebuildIndex sto
  73     = liftIO $ atomically $ writeTChan (stoIndexChan sto) RebuildIndex
  74
  75
  76 syncIndex :: Storage -> IO ()
  77 syncIndex sto
  78     = atomically $ writeTChan (stoIndexChan sto) SyncIndex
  79