Rakka/Storage.hs

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