Rakka/Storage.hs

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