{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-| This module abstracts over the details of persisting the value. Journaling is
  also handled here, if enabled. -}
module Persistence
  ( PersistentValue
  , PersistenceConfig (..)
  , getDataFile
  , getValue
  , apply
  , loadFromBackend
  , setupStorageBackend
  , syncToBackend
  ) where

import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.Except
import qualified Data.Aeson                 as Aeson
import qualified Data.Aeson.Types           as Aeson
import qualified Data.ByteString            as SBS
import qualified Data.ByteString.Char8      as SBS8
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import           Data.Foldable
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           Data.Traversable
import           Database.SQLite.Simple     (FromRow (..), NamedParam (..), Only (..), execute,
                                             execute_, executeNamed, field, open, query_)
import           System.Directory           (getFileSize, renameFile)
import           System.Exit                (die)
import           System.IO
import           System.IO.Error (tryIOError, isDoesNotExistError, isPermissionError)
import           Logger                     (Logger, LogLevel(..))
import qualified Logger
import qualified Metrics
import qualified Store

import Config (StorageBackend (..))

data PersistentValue = PersistentValue
  { PersistentValue -> PersistenceConfig
pvConfig  :: PersistenceConfig
  , PersistentValue -> TVar Value
pvValue   :: TVar Store.Value
    -- ^ contains the state of the whole database
  , PersistentValue -> TVar Bool
pvIsDirty :: TVar Bool
    -- ^ flag indicating whether the current value of 'pvValue' has not yet been persisted to disk
  , PersistentValue -> Maybe Handle
pvJournal :: Maybe Handle
  }

data PersistenceConfig = PersistenceConfig
  { PersistenceConfig -> FilePath
pcDataFile    :: FilePath
  , PersistenceConfig -> Maybe FilePath
pcJournalFile :: Maybe FilePath
  , PersistenceConfig -> Logger
pcLogger      :: Logger
  , PersistenceConfig -> Maybe IcepeakMetrics
pcMetrics     :: Maybe Metrics.IcepeakMetrics
  }

-- | Get the actual value
getValue :: PersistentValue -> STM Store.Value
getValue :: PersistentValue -> STM Value
getValue = TVar Value -> STM Value
forall a. TVar a -> STM a
readTVar (TVar Value -> STM Value)
-> (PersistentValue -> TVar Value) -> PersistentValue -> STM Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentValue -> TVar Value
pvValue

-- | Apply a modification, and write it to the journal if enabled.
apply :: Store.Modification -> PersistentValue -> IO ()
apply :: Modification -> PersistentValue -> IO ()
apply Modification
op PersistentValue
val = do
  -- append to journal if enabled
  Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PersistentValue -> Maybe Handle
pvJournal PersistentValue
val) ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
journalHandle -> do
    let entry :: ByteString
entry = Modification -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Modification
op
    Handle -> ByteString -> IO ()
LBS8.hPutStrLn Handle
journalHandle ByteString
entry
    Maybe IcepeakMetrics -> (IcepeakMetrics -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PersistenceConfig -> Maybe IcepeakMetrics
pcMetrics (PersistenceConfig -> Maybe IcepeakMetrics)
-> (PersistentValue -> PersistenceConfig)
-> PersistentValue
-> Maybe IcepeakMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentValue -> PersistenceConfig
pvConfig (PersistentValue -> Maybe IcepeakMetrics)
-> PersistentValue -> Maybe IcepeakMetrics
forall a b. (a -> b) -> a -> b
$ PersistentValue
val) ((IcepeakMetrics -> IO ()) -> IO ())
-> (IcepeakMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IcepeakMetrics
metrics -> do
      Integer
journalPos <- Handle -> IO Integer
hTell Handle
journalHandle
      Bool
_ <- Int64 -> IcepeakMetrics -> IO Bool
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m Bool
Metrics.incrementJournalWritten (ByteString -> Int64
LBS8.length ByteString
entry) IcepeakMetrics
metrics
      Integer -> IcepeakMetrics -> IO ()
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m ()
Metrics.setJournalSize Integer
journalPos IcepeakMetrics
metrics
  -- update value
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TVar Value -> (Value -> Value) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (PersistentValue -> TVar Value
pvValue PersistentValue
val) (Modification -> Value -> Value
Store.applyModification Modification
op)
    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
val) Bool
True


-- If no --data-file was supplied we default to either icepeak.json, for the file backend,
-- or icepeak.db, for the Sqlite backend
getDataFile :: StorageBackend -> Maybe FilePath -> FilePath
getDataFile :: StorageBackend -> Maybe FilePath -> FilePath
getDataFile StorageBackend
_ (Just FilePath
filePath) = FilePath
filePath
getDataFile StorageBackend
File Maybe FilePath
_ = FilePath
"icepeak.json"
getDataFile StorageBackend
Sqlite Maybe FilePath
_ = FilePath
"icepeak.db"

-- * IO

-- | Ensure that we can access the chosen storage file, and validate that it has the right file format
setupStorageBackend :: StorageBackend -> FilePath -> IO ()
setupStorageBackend :: StorageBackend -> FilePath -> IO ()
setupStorageBackend StorageBackend
File FilePath
filePath = do
  Either IOError ByteString
eitherEncodedValue <- IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO ByteString -> IO (Either IOError ByteString))
-> IO ByteString -> IO (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
SBS.readFile FilePath
filePath
  case Either IOError ByteString
eitherEncodedValue of
    Left IOError
e | IOError -> Bool
isDoesNotExistError IOError
e -> do
        -- If there is no icepeak.json file yet, we create an empty one instead.
        let message :: FilePath
message = FilePath
"WARNING: Could not read data from " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
" because the file does not exist yet. Created an empty database instead."

        -- if this fails, we want the whole program to crash since something is wrong
        FilePath -> ByteString -> IO ()
SBS.writeFile FilePath
filePath ByteString
"{}"
        FilePath -> IO ()
putStrLn FilePath
message

    Left IOError
e | IOError -> Bool
isPermissionError IOError
e ->
        FilePath -> IO ()
forall a. FilePath -> IO a
die (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"File " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" cannot be read due to a permission error. Please check the file permissions."
    -- other errors should also lead to program termination
    Left IOError
e -> FilePath -> IO ()
forall a. FilePath -> IO a
die (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e)

    -- in case the data-file is empty we write the empty object "{}" to it and return it
    Right ByteString
"" -> do
        let message :: FilePath
message = FilePath
"WARNING: The provided --data-file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
" is empty. Will write a default database of {} to this file."
        FilePath -> IO ()
putStrLn FilePath
message
        FilePath -> ByteString -> IO ()
SBS.writeFile FilePath
filePath ByteString
"{}"
    Right ByteString
encodedValue -> case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict ByteString
encodedValue of
        Left FilePath
msg  -> FilePath -> IO ()
forall a. FilePath -> IO a
die (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to decode the initial data in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
msg
        Right (Value
_value :: Aeson.Value) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setupStorageBackend StorageBackend
Sqlite FilePath
filePath = do
  -- read the data from SQLite
  Connection
conn <- IO Connection -> IO Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> IO Connection) -> IO Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Connection
open FilePath
filePath
  IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS icepeak (value BLOB)"

  [JsonRow]
jsonRows <- IO [JsonRow] -> IO [JsonRow]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [JsonRow] -> IO [JsonRow]) -> IO [JsonRow] -> IO [JsonRow]
forall a b. (a -> b) -> a -> b
$ (Connection -> Query -> IO [JsonRow]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT * from icepeak" :: IO [JsonRow])
  case [JsonRow]
jsonRows of
    -- ensure that there is one row in the table, so that we can UPDATE it later
    [] -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> Only ByteString -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"INSERT INTO icepeak (value) VALUES (?)" (ByteString -> Only ByteString
forall a. a -> Only a
Only (ByteString -> Only ByteString) -> ByteString -> Only ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
Aeson.emptyObject)
    [JsonRow]
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure()

loadFromBackend :: StorageBackend -> PersistenceConfig -> IO (Either String PersistentValue)
loadFromBackend :: StorageBackend
-> PersistenceConfig -> IO (Either FilePath PersistentValue)
loadFromBackend StorageBackend
backend PersistenceConfig
config = ExceptT FilePath IO PersistentValue
-> IO (Either FilePath PersistentValue)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FilePath IO PersistentValue
 -> IO (Either FilePath PersistentValue))
-> ExceptT FilePath IO PersistentValue
-> IO (Either FilePath PersistentValue)
forall a b. (a -> b) -> a -> b
$ do
  let metrics :: Maybe IcepeakMetrics
metrics = PersistenceConfig -> Maybe IcepeakMetrics
pcMetrics PersistenceConfig
config
      dataFilePath :: FilePath
dataFilePath = PersistenceConfig -> FilePath
pcDataFile PersistenceConfig
config

  -- We immediately set the dataSize metric, so that Prometheus can start scraping it
  IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ Maybe IcepeakMetrics -> (IcepeakMetrics -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe IcepeakMetrics
metrics ((IcepeakMetrics -> IO ()) -> IO ())
-> (IcepeakMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IcepeakMetrics
metric -> do
    Integer
size <- FilePath -> IO Integer
getFileSize FilePath
dataFilePath
    Integer -> IcepeakMetrics -> IO ()
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m ()
Metrics.setDataSize Integer
size IcepeakMetrics
metric

  -- Read the data from disk and parse it as an Aeson.Value
  Value
value <- case StorageBackend
backend of
    StorageBackend
File -> FilePath -> ExceptT FilePath IO Value
readData FilePath
dataFilePath
    StorageBackend
Sqlite -> FilePath -> ExceptT FilePath IO Value
readSqliteData FilePath
dataFilePath

  TVar Value
valueVar <- IO (TVar Value) -> ExceptT FilePath IO (TVar Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TVar Value) -> ExceptT FilePath IO (TVar Value))
-> IO (TVar Value) -> ExceptT FilePath IO (TVar Value)
forall a b. (a -> b) -> a -> b
$ Value -> IO (TVar Value)
forall a. a -> IO (TVar a)
newTVarIO Value
value
  TVar Bool
dirtyVar <- IO (TVar Bool) -> ExceptT FilePath IO (TVar Bool)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TVar Bool) -> ExceptT FilePath IO (TVar Bool))
-> IO (TVar Bool) -> ExceptT FilePath IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
  Maybe Handle
journal <- Maybe FilePath
-> (FilePath -> ExceptT FilePath IO Handle)
-> ExceptT FilePath IO (Maybe Handle)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (PersistenceConfig -> Maybe FilePath
pcJournalFile PersistenceConfig
config) FilePath -> ExceptT FilePath IO Handle
openJournal

  let val :: PersistentValue
val = PersistentValue :: PersistenceConfig
-> TVar Value -> TVar Bool -> Maybe Handle -> PersistentValue
PersistentValue
        { pvConfig :: PersistenceConfig
pvConfig  = PersistenceConfig
config
        , pvValue :: TVar Value
pvValue   = TVar Value
valueVar
        , pvIsDirty :: TVar Bool
pvIsDirty = TVar Bool
dirtyVar
        , pvJournal :: Maybe Handle
pvJournal = Maybe Handle
journal
        }
  PersistentValue -> ExceptT FilePath IO ()
recoverJournal PersistentValue
val
  PersistentValue -> ExceptT FilePath IO PersistentValue
forall (m :: * -> *) a. Monad m => a -> m a
return PersistentValue
val

syncToBackend :: StorageBackend -> PersistentValue -> IO ()
syncToBackend :: StorageBackend -> PersistentValue -> IO ()
syncToBackend StorageBackend
File PersistentValue
pv = PersistentValue -> IO ()
syncFile PersistentValue
pv
syncToBackend StorageBackend
Sqlite PersistentValue
pv = PersistentValue -> IO ()
syncSqliteFile PersistentValue
pv

-- * SQLite loading and syncing

-- | There is currently just one row and it contains only one column of type SBS.ByteString.
-- This single field holds the whole JSON value for now.
data JsonRow = JsonRow {JsonRow -> ByteString
jsonByteString :: SBS.ByteString} deriving (Int -> JsonRow -> FilePath -> FilePath
[JsonRow] -> FilePath -> FilePath
JsonRow -> FilePath
(Int -> JsonRow -> FilePath -> FilePath)
-> (JsonRow -> FilePath)
-> ([JsonRow] -> FilePath -> FilePath)
-> Show JsonRow
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [JsonRow] -> FilePath -> FilePath
$cshowList :: [JsonRow] -> FilePath -> FilePath
show :: JsonRow -> FilePath
$cshow :: JsonRow -> FilePath
showsPrec :: Int -> JsonRow -> FilePath -> FilePath
$cshowsPrec :: Int -> JsonRow -> FilePath -> FilePath
Show)

instance FromRow JsonRow where
  fromRow :: RowParser JsonRow
fromRow = ByteString -> JsonRow
JsonRow (ByteString -> JsonRow)
-> RowParser ByteString -> RowParser JsonRow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser ByteString
forall a. FromField a => RowParser a
field

-- | Read and decode the Sqlite data file from disk
readSqliteData :: FilePath -> ExceptT String IO Store.Value
readSqliteData :: FilePath -> ExceptT FilePath IO Value
readSqliteData FilePath
filePath = IO (Either FilePath Value) -> ExceptT FilePath IO Value
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath Value) -> ExceptT FilePath IO Value)
-> IO (Either FilePath Value) -> ExceptT FilePath IO Value
forall a b. (a -> b) -> a -> b
$ do
  -- read the data from SQLite
  Connection
conn <- IO Connection -> IO Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> IO Connection) -> IO Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Connection
open FilePath
filePath
  [JsonRow]
jsonRows <- IO [JsonRow] -> IO [JsonRow]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [JsonRow] -> IO [JsonRow]) -> IO [JsonRow] -> IO [JsonRow]
forall a b. (a -> b) -> a -> b
$ (Connection -> Query -> IO [JsonRow]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT * from icepeak" :: IO [JsonRow])

  case [JsonRow]
jsonRows of
    -- the 'setupStorageBackend' function verifies that we can read the database and that at least one row exists
    [] -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either FilePath Value
forall a b. b -> Either a b
Right Value
Aeson.emptyObject
    [JsonRow]
_  -> case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict (JsonRow -> ByteString
jsonByteString (JsonRow -> ByteString) -> JsonRow -> ByteString
forall a b. (a -> b) -> a -> b
$ [JsonRow] -> JsonRow
forall a. [a] -> a
head ([JsonRow] -> JsonRow) -> [JsonRow] -> JsonRow
forall a b. (a -> b) -> a -> b
$ [JsonRow]
jsonRows) of
            Left FilePath
msg  -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Value
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Value)
-> FilePath -> Either FilePath Value
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to decode the initial data: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
msg
            Right Value
value -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either FilePath Value
forall a b. b -> Either a b
Right (Value
value :: Store.Value)

-- | Write the data to the SQLite file if it has changed.
syncSqliteFile :: PersistentValue -> IO ()
syncSqliteFile :: PersistentValue -> IO ()
syncSqliteFile PersistentValue
val = do
  (Bool
dirty, Value
value) <- STM (Bool, Value) -> IO (Bool, Value)
forall a. STM a -> IO a
atomically (STM (Bool, Value) -> IO (Bool, Value))
-> STM (Bool, Value) -> IO (Bool, Value)
forall a b. (a -> b) -> a -> b
$ (,) (Bool -> Value -> (Bool, Value))
-> STM Bool -> STM (Value -> (Bool, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
val)
                                     STM (Value -> (Bool, Value)) -> STM Value -> STM (Bool, Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Value -> STM Value
forall a. TVar a -> STM a
readTVar (PersistentValue -> TVar Value
pvValue PersistentValue
val)
                                     STM (Bool, Value) -> STM () -> STM (Bool, Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
val) Bool
False
  -- simple optimization: only write when something changed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dirty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let filePath :: FilePath
filePath = PersistenceConfig -> FilePath
pcDataFile (PersistenceConfig -> FilePath) -> PersistenceConfig -> FilePath
forall a b. (a -> b) -> a -> b
$ PersistentValue -> PersistenceConfig
pvConfig PersistentValue
val

    Connection
conn <- FilePath -> IO Connection
open FilePath
filePath
    -- we can always UPDATE here, since we know that there will be at least one row, since
    -- we issue an INSERT when we load in an empty database
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> [NamedParam] -> IO ()
executeNamed Connection
conn Query
"UPDATE icepeak SET value = :value" [Text
":value" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
value]

    -- the journal is idempotent, so there is no harm if icepeak crashes between
    -- the previous and the next action
    PersistentValue -> IO ()
truncateJournal PersistentValue
val

    -- handle metrics last
    PersistentValue -> IO ()
updateMetrics PersistentValue
val

-- * File syncing

-- | Write the data to disk if it has changed.
syncFile :: PersistentValue -> IO ()
syncFile :: PersistentValue -> IO ()
syncFile PersistentValue
val = do
  (Bool
dirty, Value
value) <- STM (Bool, Value) -> IO (Bool, Value)
forall a. STM a -> IO a
atomically (STM (Bool, Value) -> IO (Bool, Value))
-> STM (Bool, Value) -> IO (Bool, Value)
forall a b. (a -> b) -> a -> b
$ (,) (Bool -> Value -> (Bool, Value))
-> STM Bool -> STM (Value -> (Bool, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
val)
                                     STM (Value -> (Bool, Value)) -> STM Value -> STM (Bool, Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Value -> STM Value
forall a. TVar a -> STM a
readTVar (PersistentValue -> TVar Value
pvValue PersistentValue
val)
                                     STM (Bool, Value) -> STM () -> STM (Bool, Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
val) Bool
False
  -- simple optimization: only write when something changed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dirty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let fileName :: FilePath
fileName = PersistenceConfig -> FilePath
pcDataFile (PersistenceConfig -> FilePath) -> PersistenceConfig -> FilePath
forall a b. (a -> b) -> a -> b
$ PersistentValue -> PersistenceConfig
pvConfig PersistentValue
val
        tempFileName :: FilePath
tempFileName = FilePath
fileName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".new"
    -- we first write to a temporary file here and then do a rename on it
    -- because rename is atomic on Posix and a crash during writing the
    -- temporary file will thus not corrupt the datastore
    FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
tempFileName (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
value)
    FilePath -> FilePath -> IO ()
renameFile FilePath
tempFileName FilePath
fileName

    -- the journal is idempotent, so there is no harm if icepeak crashes between
    -- the previous and the next action
    PersistentValue -> IO ()
truncateJournal PersistentValue
val

    -- handle metrics last
    PersistentValue -> IO ()
updateMetrics PersistentValue
val

-- * Private helper functions

-- Note that some of these functions are still exported in order to be usable in the test suite

-- | Seek to the beginning of the journal file and set the file size to zero.
-- This should be called after all journal entries have been replayed, and the data has been
-- synced to disk.
truncateJournal :: PersistentValue -> IO ()
truncateJournal :: PersistentValue -> IO ()
truncateJournal PersistentValue
val =
    Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PersistentValue -> Maybe Handle
pvJournal PersistentValue
val) ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
journalHandle -> do
      -- we must seek back to the beginning of the file *before* calling hSetFileSize, since that
      -- function does not change the file cursor, which means that the first write that follows
      -- would fill up the file with \NUL bytes up to the original cursor position.
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
journalHandle SeekMode
AbsoluteSeek Integer
0
      Handle -> Integer -> IO ()
hSetFileSize Handle
journalHandle Integer
0

-- | We keep track of three metrics related to persistence:
-- 1. The current size of the data file
-- 2. The current size of the journal file
-- 3. The total amount of data written to disk since the process was started
--    (not counting journal writes)
updateMetrics :: PersistentValue -> IO ()
updateMetrics :: PersistentValue -> IO ()
updateMetrics PersistentValue
val = do
    let filePath :: FilePath
filePath = PersistenceConfig -> FilePath
pcDataFile (PersistenceConfig -> FilePath)
-> (PersistentValue -> PersistenceConfig)
-> PersistentValue
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentValue -> PersistenceConfig
pvConfig (PersistentValue -> FilePath) -> PersistentValue -> FilePath
forall a b. (a -> b) -> a -> b
$ PersistentValue
val
        metrics :: Maybe IcepeakMetrics
metrics = PersistenceConfig -> Maybe IcepeakMetrics
pcMetrics (PersistenceConfig -> Maybe IcepeakMetrics)
-> (PersistentValue -> PersistenceConfig)
-> PersistentValue
-> Maybe IcepeakMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentValue -> PersistenceConfig
pvConfig (PersistentValue -> Maybe IcepeakMetrics)
-> PersistentValue -> Maybe IcepeakMetrics
forall a b. (a -> b) -> a -> b
$ PersistentValue
val
    Maybe IcepeakMetrics -> (IcepeakMetrics -> IO Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe IcepeakMetrics
metrics ((IcepeakMetrics -> IO Bool) -> IO ())
-> (IcepeakMetrics -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IcepeakMetrics
metric -> do
      Integer
size <- FilePath -> IO Integer
getFileSize FilePath
filePath
      Integer -> IcepeakMetrics -> IO ()
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m ()
Metrics.setDataSize Integer
size IcepeakMetrics
metric
      Int -> IcepeakMetrics -> IO ()
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m ()
Metrics.setJournalSize (Int
0 :: Int) IcepeakMetrics
metric
      Integer -> IcepeakMetrics -> IO Bool
forall (m :: * -> *) a.
(MonadMonitor m, Real a) =>
a -> IcepeakMetrics -> m Bool
Metrics.incrementDataWritten Integer
size IcepeakMetrics
metric

-- | Open or create the journal file
openJournal :: FilePath -> ExceptT String IO Handle
openJournal :: FilePath -> ExceptT FilePath IO Handle
openJournal FilePath
journalFile = IO (Either FilePath Handle) -> ExceptT FilePath IO Handle
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath Handle) -> ExceptT FilePath IO Handle)
-> IO (Either FilePath Handle) -> ExceptT FilePath IO Handle
forall a b. (a -> b) -> a -> b
$ do
  Either SomeException Handle
eitherHandle <- IO Handle -> IO (Either SomeException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Handle -> IO (Either SomeException Handle))
-> IO Handle -> IO (Either SomeException Handle)
forall a b. (a -> b) -> a -> b
$ do
    Handle
h <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
journalFile IOMode
ReadWriteMode
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
    Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
  case Either SomeException Handle
eitherHandle :: Either SomeException Handle of
    Left SomeException
exc -> Either FilePath Handle -> IO (Either FilePath Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Handle -> IO (Either FilePath Handle))
-> Either FilePath Handle -> IO (Either FilePath Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Handle
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Handle)
-> FilePath -> Either FilePath Handle
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to open journal file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc
    Right Handle
fileHandle -> Either FilePath Handle -> IO (Either FilePath Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Handle -> IO (Either FilePath Handle))
-> Either FilePath Handle -> IO (Either FilePath Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> Either FilePath Handle
forall a b. b -> Either a b
Right Handle
fileHandle

-- | Read the modifications from the journal file, apply them and sync again.
-- This should be done when loading the database from disk.
recoverJournal :: PersistentValue -> ExceptT String IO ()
recoverJournal :: PersistentValue -> ExceptT FilePath IO ()
recoverJournal PersistentValue
pval = Maybe Handle
-> (Handle -> ExceptT FilePath IO ()) -> ExceptT FilePath IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PersistentValue -> Maybe Handle
pvJournal PersistentValue
pval) ((Handle -> ExceptT FilePath IO ()) -> ExceptT FilePath IO ())
-> (Handle -> ExceptT FilePath IO ()) -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
journalHandle -> IO (Either FilePath ()) -> ExceptT FilePath IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath ()) -> ExceptT FilePath IO ())
-> IO (Either FilePath ()) -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ (Either SomeException () -> Either FilePath ())
-> IO (Either SomeException ()) -> IO (Either FilePath ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either SomeException () -> Either FilePath ()
forall a. Either SomeException a -> Either FilePath a
formatErr (IO (Either SomeException ()) -> IO (Either FilePath ()))
-> IO (Either SomeException ()) -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
  Value
initialValue <- STM Value -> IO Value
forall a. STM a -> IO a
atomically (STM Value -> IO Value) -> STM Value -> IO Value
forall a b. (a -> b) -> a -> b
$ TVar Value -> STM Value
forall a. TVar a -> STM a
readTVar (PersistentValue -> TVar Value
pvValue PersistentValue
pval)
  (Value
finalValue, Integer
successful, Integer
total) <- Handle -> Value -> IO (Value, Integer, Integer)
runRecovery Handle
journalHandle Value
initialValue

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
successful Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TVar Value -> Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PersistentValue -> TVar Value
pvValue PersistentValue
pval) Value
finalValue
      TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (PersistentValue -> TVar Bool
pvIsDirty PersistentValue
pval) Bool
True
    -- syncing takes care of cleaning the journal
    PersistentValue -> IO ()
syncFile PersistentValue
pval

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
total Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval Text
"Journal replayed"
    PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"  failed:     " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> FilePath) -> Integer -> FilePath
forall a b. (a -> b) -> a -> b
$ Integer
total Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
successful)
    PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"  successful: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> FilePath) -> Integer -> FilePath
forall a b. (a -> b) -> a -> b
$ Integer
successful)

  where
    formatErr :: Either SomeException a -> Either String a
    formatErr :: Either SomeException a -> Either FilePath a
formatErr (Left SomeException
exc) = FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to read journal: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc
    formatErr (Right a
x)  = a -> Either FilePath a
forall a b. b -> Either a b
Right a
x

    runRecovery :: Handle -> Value -> IO (Value, Integer, Integer)
runRecovery Handle
journalHandle Value
value = do
      -- read modifications from the beginning
      Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
journalHandle SeekMode
AbsoluteSeek Integer
0
      Handle
-> (ByteString
    -> (Value, Integer, Integer) -> IO (Value, Integer, Integer))
-> (Value, Integer, Integer)
-> IO (Value, Integer, Integer)
forall a. Handle -> (ByteString -> a -> IO a) -> a -> IO a
foldJournalM Handle
journalHandle ByteString
-> (Value, Integer, Integer) -> IO (Value, Integer, Integer)
forall c b.
(Eq c, Show c, Num b, Num c) =>
ByteString -> (Value, b, c) -> IO (Value, b, c)
replayLine (Value
value, Integer
0 :: Integer, Integer
0 :: Integer)

    replayLine :: ByteString -> (Value, b, c) -> IO (Value, b, c)
replayLine ByteString
line (!Value
value, !b
successful, !c
total) = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (c
total c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval Text
"Journal not empty, recovering"
      case ByteString -> Either FilePath Modification
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict ByteString
line of
        Left FilePath
err -> do
          let lineNumber :: c
lineNumber = c
total c -> c -> c
forall a. Num a => a -> a -> a
+ c
1
          PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> c -> Text
forall a. Show a => FilePath -> a -> Text
failedRecoveryMsg FilePath
err c
lineNumber
          (Value, b, c) -> IO (Value, b, c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
value, b
successful, c
total c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
        Right Modification
op -> (Value, b, c) -> IO (Value, b, c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Modification -> Value -> Value
Store.applyModification Modification
op Value
value, b
successful b -> b -> b
forall a. Num a => a -> a -> a
+ b
1, c
total c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)

    failedRecoveryMsg :: FilePath -> a -> Text
failedRecoveryMsg FilePath
err a
line = Text
"Failed to recover journal entry "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
line) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
err

-- | Read and decode the data file from disk
readData :: FilePath -> ExceptT String IO Store.Value
readData :: FilePath -> ExceptT FilePath IO Value
readData FilePath
filePath = IO (Either FilePath Value) -> ExceptT FilePath IO Value
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath Value) -> ExceptT FilePath IO Value)
-> IO (Either FilePath Value) -> ExceptT FilePath IO Value
forall a b. (a -> b) -> a -> b
$ do
  Either IOError ByteString
eitherEncodedValue <- IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO ByteString -> IO (Either IOError ByteString))
-> IO ByteString -> IO (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
SBS.readFile FilePath
filePath
  case Either IOError ByteString
eitherEncodedValue of
    -- we do not expect any errors here, since we validated the file earlier already
    Left IOError
e -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Value
forall a b. a -> Either a b
Left (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e)
    Right ByteString
encodedValue -> case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict ByteString
encodedValue of
      Left FilePath
msg  -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Value
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Value)
-> FilePath -> Either FilePath Value
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to decode the initial data: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
msg
      Right Value
value -> Either FilePath Value -> IO (Either FilePath Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath Value -> IO (Either FilePath Value))
-> Either FilePath Value -> IO (Either FilePath Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either FilePath Value
forall a b. b -> Either a b
Right Value
value

-- | Log a message in the context of a PersistentValue.
logMessage :: PersistentValue -> Text -> IO ()
logMessage :: PersistentValue -> Text -> IO ()
logMessage PersistentValue
pval Text
msg = Logger -> LogLevel -> Text -> IO ()
Logger.postLogBlocking (PersistenceConfig -> Logger
pcLogger (PersistenceConfig -> Logger) -> PersistenceConfig -> Logger
forall a b. (a -> b) -> a -> b
$ PersistentValue -> PersistenceConfig
pvConfig PersistentValue
pval) LogLevel
LogInfo Text
msg

-- | Left fold over all journal entries.
foldJournalM :: Handle -> (SBS8.ByteString -> a -> IO a) -> a -> IO a
foldJournalM :: Handle -> (ByteString -> a -> IO a) -> a -> IO a
foldJournalM Handle
h ByteString -> a -> IO a
f = a -> IO a
go
  where
    go :: a -> IO a
go !a
x = do
      Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
      if Bool
eof
        then a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        else do
          ByteString
line <- Handle -> IO ByteString
SBS8.hGetLine Handle
h
          a
x' <- ByteString -> a -> IO a
f ByteString
line a
x
          a -> IO a
go a
x'