Rakka/Storage.hs

   1 module Rakka.Storage
   2     ( Storage
   3
   4     -- re-export from Rakka.Storage.Types
   5     , SearchResult(..)
   6     , SnippetFragment(..)
   7
   8     , mkStorage -- private
   9
  10     , getPage
  11     , putPage
  12     , deletePage
  13
  14     , getPageA
  15     , putPageA
  16     , deletePageA
  17
  18     , getAttachment
  19     , putAttachment
  20
  21     , getDirContents
  22     , getDirContentsA
  23
  24     , searchPages
  25
  26     , rebuildIndex
  27     )
  28     where
  29
  30 import           Control.Arrow.ArrowIO
  31 import           Control.Concurrent.STM
  32 import           Control.Monad
  33 import           Control.Monad.Trans
  34 import           Data.Maybe
  35 import           Network.HTTP.Lucu
  36 import           Rakka.Attachment
  37 import           Rakka.Page
  38 import           Rakka.Storage.Impl
  39 import           Rakka.Storage.Types
  40 import           Subversion.Types
  41 import           System.IO
  42 import           Subversion.Repository
  43 import           Text.HyperEstraier hiding (WriteLock)
  44
  45
  46 mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
  47 mkStorage lsdir repos mkDraft
  48     = do chan <- startIndexManager lsdir repos mkDraft
  49          let sto = Storage {
  50                      stoRepository = repos
  51                    , stoIndexChan  = chan
  52                    }
  53          syncIndex sto
  54          return sto
  55
  56
  57 getPage :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m (Maybe Page)
  58 getPage = ((liftIO .) .) . getPage' . stoRepository
  59
  60
  61 putPage :: MonadIO m => Storage -> Maybe String -> Page -> m StatusCode
  62 putPage sto userID page
  63     = liftIO $ do st <- putPage' (stoRepository sto) userID page
  64                   syncIndex sto
  65                   return st
  66
  67
  68 deletePage :: MonadIO m => Storage -> Maybe String -> PageName -> m StatusCode
  69 deletePage sto userID name
  70     = liftIO $ do st <- deletePage' (stoRepository sto) userID name
  71                   syncIndex sto
  72                   return st
  73
  74
  75 getPageA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) (Maybe Page)
  76 getPageA = arrIO2 . getPage
  77
  78
  79 putPageA :: ArrowIO a => Storage -> a (Maybe String, Page) StatusCode
  80 putPageA = arrIO2 . putPage
  81
  82
  83 deletePageA :: ArrowIO a => Storage -> a (Maybe String, PageName) StatusCode
  84 deletePageA = arrIO2 . deletePage
  85
  86
  87 getDirContents :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m [PageName]
  88 getDirContents = ((liftIO .) .) . getDirContents' . stoRepository
  89
  90
  91 getDirContentsA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) [PageName]
  92 getDirContentsA = arrIO2 . getDirContents
  93
  94
  95 searchPages :: MonadIO m => Storage -> Condition -> m [SearchResult]
  96 searchPages sto cond
  97     = liftIO $
  98       do var <- newEmptyTMVarIO
  99          atomically $ writeTChan (stoIndexChan sto) (SearchIndex cond var)
 100          atomically $ takeTMVar var
 101
 102
 103 rebuildIndex :: MonadIO m => Storage -> m ()
 104 rebuildIndex sto
 105     = liftIO $ atomically $ writeTChan (stoIndexChan sto) RebuildIndex
 106
 107
 108 syncIndex :: Storage -> IO ()
 109 syncIndex sto
 110     = atomically $ writeTChan (stoIndexChan sto) SyncIndex
 111
 112
 113 getAttachment :: (Attachment a, MonadIO m) =>
 114                  Storage
 115               -> PageName
 116               -> String
 117               -> Maybe RevNum
 118               -> m (Maybe a)
 119 getAttachment = (((liftIO .) .) .) . getAttachment' . stoRepository
 120
 121
 122 putAttachment :: (Attachment a, MonadIO m) =>
 123                  Storage
 124               -> Maybe String
 125               -> Maybe RevNum
 126               -> PageName
 127               -> String
 128               -> a
 129               -> m StatusCode
 130 putAttachment = (((((liftIO .) .) .) .) .) . putAttachment' . stoRepository