{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module RON.Storage.IO (
module X,
Handle,
Storage,
newHandle,
runStorage,
) where
import Control.Exception (catch, throwIO)
import Control.Monad (filterM, unless, when)
import Control.Monad.Except (ExceptT (ExceptT), MonadError,
runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT (ReaderT), ask, runReaderT)
import Control.Monad.Trans (lift)
import Data.Bits (shiftL)
import qualified Data.ByteString.Lazy as BSL
import Data.IORef (IORef, newIORef)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Word (Word64)
import Network.Info (MAC (MAC), getNetworkInterfaces, mac)
import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock)
import RON.Event (EpochTime, ReplicaClock, ReplicaId, advance,
applicationSpecific, getEvents, getPid)
import System.Directory (canonicalizePath, createDirectoryIfMissing,
doesDirectoryExist, doesPathExist,
listDirectory, removeFile, renameDirectory)
import System.FilePath ((</>))
import System.IO.Error (isDoesNotExistError)
import RON.Storage as X
newtype Storage a = Storage (ExceptT String (ReaderT FilePath EpochClock) a)
deriving (Applicative, Functor, Monad, MonadError String, MonadIO)
runStorage :: Handle -> Storage a -> IO a
runStorage Handle{hReplica, hDataDir, hClock} (Storage action) = do
res <-
runEpochClock hReplica hClock $
(`runReaderT` hDataDir) $
runExceptT action
either fail pure res
instance ReplicaClock Storage where
getPid = Storage . lift $ lift getPid
getEvents = Storage . lift . lift . getEvents
advance = Storage . lift . lift . advance
instance MonadStorage Storage where
getCollections = Storage $ do
dataDir <- ask
liftIO $
listDirectory dataDir
>>= filterM (doesDirectoryExist . (dataDir </>))
getDocuments :: forall doc. Collection doc => Storage [DocId doc]
getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc)
getDocumentVersions = listDirectoryIfExists . docDir
saveVersionContent docid version content =
Storage $ do
dataDir <- ask
let docdir = dataDir </> docDir docid
liftIO $ do
createDirectoryIfMissing True docdir
BSL.writeFile (docdir </> version) content
loadVersionContent docid version = Storage $ do
dataDir <- ask
liftIO $ BSL.readFile $ dataDir </> docDir docid </> version
deleteVersion docid version = Storage $ do
dataDir <- ask
liftIO $ do
let file = dataDir </> docDir docid </> version
removeFile file
`catch` \e ->
unless (isDoesNotExistError e) $ throwIO e
changeDocId old new = Storage $ do
db <- ask
let oldPath = db </> docDir old
newPath = db </> docDir new
oldPathCanon <- liftIO $ canonicalizePath oldPath
newPathCanon <- liftIO $ canonicalizePath newPath
when (newPathCanon /= oldPathCanon) $ do
newPathExists <- liftIO $ doesPathExist newPath
when newPathExists $
throwError $ unwords
[ "changeDocId"
, show old, "[", oldPath, "->", oldPathCanon, "]"
, show new, "[", newPath, "->", newPathCanon, "]"
, ": internal error: new document id is already taken"
]
when (newPath /= oldPath) $
liftIO $ renameDirectory oldPath newPath
data Handle = Handle
{ hClock :: IORef EpochTime
, hDataDir :: FilePath
, hReplica :: ReplicaId
}
newHandle :: FilePath -> IO Handle
newHandle hDataDir = do
time <- getCurrentEpochTime
hClock <- newIORef time
hReplica <- applicationSpecific <$> getMacAddress
pure Handle{hDataDir, hClock, hReplica}
listDirectoryIfExists :: FilePath -> Storage [FilePath]
listDirectoryIfExists relpath = Storage $ do
dataDir <- ask
let dir = dataDir </> relpath
liftIO $ do
exists <- doesDirectoryExist dir
if exists then listDirectory dir else pure []
docDir :: forall a . Collection a => DocId a -> FilePath
docDir (DocId dir) = collectionName @a </> dir
getMacAddress :: IO Word64
getMacAddress = decodeMac <$> getMac where
getMac
= fromMaybe
(error "Can't get any non-zero MAC address of this machine")
. listToMaybe
. filter (/= minBound)
. map mac
<$> getNetworkInterfaces
decodeMac (MAC b5 b4 b3 b2 b1 b0)
= fromIntegral b5 `shiftL` 40
+ fromIntegral b4 `shiftL` 32
+ fromIntegral b3 `shiftL` 24
+ fromIntegral b2 `shiftL` 16
+ fromIntegral b1 `shiftL` 8
+ fromIntegral b0