diff --git a/raft.cabal b/raft.cabal --- a/raft.cabal +++ b/raft.cabal @@ -1,5 +1,5 @@ name : raft -version : 0.3.7.2 +version : 0.3.11.0 synopsis : Miscellaneous Haskell utilities for data structures and data manipulation. description : This Haskell library contains miscellaneous data structures and data manipulation functions for general uses. @@ -7,7 +7,7 @@ license-file : LICENSE author : Brian W Bush maintainer : Brian W Bush -copyright : (c) 2005-16 Brian W Bush +copyright : (c) 2005-17 Brian W Bush category : Data stability : Experimental build-type : Simple @@ -26,6 +26,7 @@ library exposed-modules : Control.Monad.Except.Util + Control.Monad.Util Data.Color.Util Data.Default.Util Data.EdgeTree @@ -35,6 +36,8 @@ Data.Function.MapReduce Data.Function.MapReduce.Internal Data.Function.Util + Data.Journal + Data.Journal.Empty Data.List.Util Data.List.Util.Listable Data.Maybe.Util @@ -47,10 +50,12 @@ Math.Roots.Bisection Math.Series if !flag(minimal) - exposed-modules: Data.Aeson.Util + exposed-modules: Control.Concurrent.Util + Data.Aeson.Util Data.Attoparsec.Util Data.Function.MapReduce.Parallel Data.Function.Tabulated + Data.Journal.File Data.Relational Data.Relational.Lists Data.Relational.Value @@ -73,8 +78,10 @@ if !flag(minimal) build-depends : aeson >= 0.11.2 , attoparsec >= 0.13.0 + , cereal , parallel >= 3.2.0 , scientific >= 0.3.3 + , stm , zlib >= 0.5.4 exposed : True buildable : True diff --git a/src/Control/Concurrent/Util.hs b/src/Control/Concurrent/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Util.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.Util +-- Copyright : (c) 2016-17 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | Utilities related to concurrency. +-- +----------------------------------------------------------------------------- + + +module Control.Concurrent.Util ( +-- * Miscellaneous + makeCounter +) where + + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (newTVarIO, readTVar, writeTVar) + + +-- | Make a counter. +makeCounter :: (a -> a) -- ^ How to increment the counter. + -> a -- ^ The initial value of the counter. + -> IO (IO a) -- ^ Action for creating the action to increment the counter. +makeCounter f i = + do + counter <- newTVarIO i + let + next = + atomically + $ do + j <- f <$> readTVar counter + writeTVar counter j + return j + return next diff --git a/src/Control/Monad/Except/Util.hs b/src/Control/Monad/Except/Util.hs --- a/src/Control/Monad/Except/Util.hs +++ b/src/Control/Monad/Except/Util.hs @@ -13,7 +13,8 @@ ----------------------------------------------------------------------------- -{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} module Control.Monad.Except.Util ( @@ -22,18 +23,40 @@ , deny -- * Input/Output , tryIO +, guardIO +, eitherError +, runToIO ) where -import Control.Exception (IOException, try) +import Control.Exception (IOException, throw, try) import Control.Monad (unless, when) -import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError) +import Control.Monad.Except (ExceptT, MonadError, MonadIO, liftIO, runExceptT, throwError) import Data.String (IsString(..)) +import System.IO.Error (tryIOError) -- | Attempt an IO action. tryIO :: (IsString e, MonadError e m, MonadIO m) => IO a -> m a tryIO = (>>= either (\e -> throwError . fromString $ show (e :: IOException)) return) . liftIO . try + + +-- | Catch 'Control.Exception.IOException' and throw it into 'MonadError String'. Derived from . +guardIO :: (MonadIO m, MonadError String m) => IO a -> m a +guardIO = + (either (throwError . show) return =<<) + . liftIO + . tryIOError + + +-- | Throw 'Data.Either.Left' into 'Control.Exception.IOException'. +eitherError :: (a -> b) -> Either String a -> IO b +eitherError f = either (throw . userError) (return . f) + + +-- | Run 'Control.Monad.Except.ExceptT' to 'System.IO'. +runToIO :: ExceptT String IO a -> IO a +runToIO = (eitherError id =<<) . runExceptT -- | Make an assertion. diff --git a/src/Control/Monad/Util.hs b/src/Control/Monad/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Util.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Util +-- Copyright : (c) 2017 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | Utilities for monads. +-- +----------------------------------------------------------------------------- + + +module Control.Monad.Util ( +-- * Iteration + collectWhile +) where + + +-- | Collect the results of running an action repeatedly while a condition holds. +collectWhile :: Monad m + => m a -- ^ The action to repeat. + -> m Bool -- ^ The action for the condition that must hold. + -> m [a] -- ^ An action collecting the results. +collectWhile next test = + do + t <- test + if t + then do + n <- next + (n :) <$> collectWhile next test + else return [] diff --git a/src/Data/Journal.hs b/src/Data/Journal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Journal.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Journal +-- Copyright : (c) 2017 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | Simple logging to a journal. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE FlexibleContexts #-} + + +module Data.Journal ( +-- * Types + Key +, Entry +, Journal(..) +) where + + +import Control.Monad.Except (MonadError, MonadIO) +import Data.ByteString.Char8 (ByteString) + + +-- | Journal entries are keyed by byte strings. +type Key = ByteString + + +-- | Journal entries are byte strings. +type Entry = ByteString + + +-- | Type class for logging to a journal. +class Journal a where + + -- | Append a log entry. + append :: (MonadIO m, MonadError String m) + => a -- ^ The journal. + -> (Key, Entry) -- ^ The key and value to be logged. + -> m () -- ^ An action to peform the logging. + + -- | Erase a log entry. + erase :: (MonadIO m, MonadError String m) + => a -- ^ The journal. + -> Key -- ^ The key for the entry to be erased. + -> m () -- ^ An action to erase the log entry. + + -- | Replay the journal to extract all log entries. + replay :: (MonadIO m, MonadError String m) + => Bool -- ^ Whether to compress the journal, erasing obsolete entries. + -> a -- ^ The journal. + -> m [(Key, Entry)] -- ^ An action listing all log entries. + + -- | Erase all log entries from the journal. + clear :: (MonadIO m, MonadError String m) + => a -- ^ The journal. + -> m () -- ^ An action to erase all log entries. + + -- | Close a journal. + close :: (MonadIO m, MonadError String m) + => a -- ^ The journal. + -> m () -- ^ An action to close the journal. diff --git a/src/Data/Journal/Empty.hs b/src/Data/Journal/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Journal/Empty.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Journal.Empty +-- Copyright : (c) 2017 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | A journal that does no logging. +-- +----------------------------------------------------------------------------- + + +module Data.Journal.Empty ( + -- * Types + EmptyJournal(..) +) where + + +import Data.Journal (Journal(..)) + + +-- | A journal that does no logging. +data EmptyJournal = + EmptyJournal + deriving (Eq, Read, Show) + +instance Journal EmptyJournal where + append = const . const $ return () + erase = const . const $ return () + replay = const . const $ return [] + clear = const $ return () + close = const $ return () diff --git a/src/Data/Journal/File.hs b/src/Data/Journal/File.hs new file mode 100644 --- /dev/null +++ b/src/Data/Journal/File.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Journal.File +-- Copyright : (c) 2017 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | A file-backed journal that does no logging. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + + +module Data.Journal.File ( + -- * Types + FileJournal + -- * Construction +, openJournal +, openJournalIO +) where + + +import Control.Arrow (second) +import Control.Monad (when, void) +import Control.Monad.Except (MonadError, MonadIO, runExceptT) +import Control.Monad.Except.Util (guardIO, eitherError) +import Control.Monad.Util (collectWhile) +import Data.ByteString.Char8 as BS (head, hGet, hPut, length, singleton) +import Data.Journal (Entry, Journal(..), Key) +import Data.Map.Lazy as M (filter, fromList, map, toList) +import Data.Maybe (fromJust, isJust) +import Data.Serialize (decode, encode) +import Data.Word (Word32) +import System.IO (BufferMode(..), Handle, IOMode(..), SeekMode(..), hClose, hFlush, hGetPosn, hIsEOF, hSeek, hSetBuffering, hSetFileSize, hSetPosn, openFile) + + +-- | A file-backed journal. +data FileJournal = + FileJournal + { + file :: FilePath -- ^ The file name. + , handle :: Handle -- ^ The handle to the file. + } + deriving (Eq, Show) + +instance Journal FileJournal where + + append FileJournal{..} = guardIO . save handle . second Just + + erase FileJournal{..} = guardIO . save handle . (, Nothing) + + replay compact FileJournal{..} = + guardIO + $ do + hSeek handle AbsoluteSeek 0 + keyEntries <- + M.toList + . M.map fromJust + . M.filter isJust + . M.fromList + <$> collectWhile (load handle) (hasNext handle) + when compact + $ do -- FIXME: Make this atomic. + hSeek handle AbsoluteSeek 0 + hSetFileSize handle 0 + mapM_ (save handle . second Just) keyEntries + return keyEntries + + clear FileJournal{..} = + guardIO + $ do + hSeek handle AbsoluteSeek 0 + hSetFileSize handle 0 + + close FileJournal{..} = guardIO $ hClose handle + + +-- | Determine whether there is a valid next entry in the journal. +hasNext :: Handle -- ^ The file handle for the journal. + -> IO Bool -- ^ An action to determine whether there is a valid next entry. +hasNext h = + do + e <- hIsEOF h + if e + then return False + else do + i <- hGetPosn h + flag <- hGetEnum h + hSetPosn i + return flag + + +-- | Get a one-byte enum. +hGetEnum :: Enum a + => Handle -- ^ The file handle. + -> IO a -- ^ An action to read the enum. +hGetEnum h = toEnum . fromEnum . BS.head <$> BS.hGet h 1 + + +-- | Put a one-byte enum. +hPutEnum :: Enum a + => Handle -- ^ The file handle. + -> a -- ^ The enum. + -> IO () -- ^ An action to write the enum. +hPutEnum h = BS.hPut h . BS.singleton . toEnum . fromEnum + + +-- | Write an entry to a journal. +save :: Handle -- ^ The file handle for the journal. + -> (Key, Maybe Entry) -- ^ The entry, or whose lack of an entry indicates deletion. + -> IO () -- ^ An action to write the entry. +save h (key, entry) = + do + i <- hGetPosn h + hPutEnum h False + let + payload = encode (key, entry) + n = (toEnum :: Int -> Word32) $ BS.length payload + n' = encode n + BS.hPut h n' + BS.hPut h payload + j <- hGetPosn h + hSetPosn i + hPutEnum h True + hSetPosn j + hFlush h + + +-- | Read an entry from a journal. +load :: Handle -- ^ The file handle for the journal. + -> IO (Key, Maybe Entry) -- ^ An action to read the entry, or whose lack of an entry indicates deletion. +load h = + do + void $ BS.hGet h 1 + n' <- BS.hGet h 4 + n <- eitherError (fromEnum :: Word32 -> Int) $ decode n' + payload <- BS.hGet h n + eitherError id $ decode payload + + +-- | Open a journal. +openJournal :: (MonadIO m, MonadError String m) + => FilePath -- ^ The location of the journal file. + -> m FileJournal -- ^ An action to open the journal. +openJournal file = + guardIO + $ do + handle <- openFile file ReadWriteMode + hSetBuffering handle $ BlockBuffering Nothing + hSeek handle SeekFromEnd 0 + return FileJournal{..} + + +-- | Open a journal. +openJournalIO :: FilePath -- ^ The location of the journal file. + -> IO FileJournal -- ^ An IO action to open the journal. +openJournalIO = (eitherError id =<<) . runExceptT . openJournal diff --git a/src/Data/Maybe/Util.hs b/src/Data/Maybe/Util.hs --- a/src/Data/Maybe/Util.hs +++ b/src/Data/Maybe/Util.hs @@ -8,7 +8,7 @@ -- Stability : Stable -- Portability : Portable -- --- | Utility functions for 'Data.Maybe.Maybe'. +-- | Utility functions for 'Data.Maybe'. -- -----------------------------------------------------------------------------