├── LICENSE ├── Setup.hs ├── event-source.cabal ├── src └── Event │ └── Source.hs └── stack.yaml /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Gabriel Gonzalez 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright notice, 7 | this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright notice, 9 | this list of conditions and the following disclaimer in the documentation 10 | and/or other materials provided with the distribution. 11 | * Neither the name of Gabriel Gonzalez nor the names of other contributors 12 | may be used to endorse or promote products derived from this software 13 | without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /event-source.cabal: -------------------------------------------------------------------------------- 1 | Name: event-source 2 | Version: 1.0.0 3 | Cabal-Version: >=1.8.0.2 4 | Build-Type: Simple 5 | License: BSD3 6 | License-File: LICENSE 7 | Copyright: 2016 Gabriel Gonzalez 8 | Author: Gabriel Gonzalez 9 | Maintainer: Gabriel439@gmail.com 10 | Bug-Reports: https://github.com/Gabriel439/Haskell-Event-Source-Library/issues 11 | Synopsis: Event sourcing library 12 | Description: Event sourcing library 13 | Category: Control 14 | Source-Repository head 15 | Type: git 16 | Location: https://github.com/Gabriel439/Haskell-Event-Source-Library 17 | 18 | Library 19 | HS-Source-Dirs: src 20 | Build-Depends: 21 | base >= 4.5 && < 5 , 22 | bytestring < 0.11, 23 | cereal < 0.6 , 24 | comonad >= 4.0 && < 6 , 25 | containers < 0.6 , 26 | directory < 1.3 , 27 | managed < 1.1 , 28 | pipes >= 4.0 && < 4.2 , 29 | profunctors < 5.3 , 30 | transformers >= 0.2.0.0 && < 0.6 31 | Exposed-Modules: Event.Source 32 | GHC-Options: -O2 -Wall 33 | -------------------------------------------------------------------------------- /src/Event/Source.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Event.Source where 5 | 6 | import Control.Applicative 7 | import Control.Exception (throwIO) 8 | import Control.Comonad (Comonad(..)) 9 | import Control.Monad.Managed (Managed) 10 | import Data.Functor.Constant (Constant(..)) 11 | import Data.Monoid 12 | import Data.Profunctor (Profunctor(..)) 13 | import Data.Sequence ((|>)) 14 | import Data.Serialize (Serialize(..)) 15 | import Pipes (Producer, await, liftIO, yield, (>->)) 16 | import Prelude hiding (all, any, length, sum) 17 | 18 | import qualified Data.Foldable 19 | import qualified Data.ByteString as ByteString 20 | import qualified Data.Sequence 21 | import qualified Data.Serialize as Serialize 22 | import qualified System.Directory 23 | 24 | {-| Efficient representation of a left fold that preserves the fold's step 25 | function, initial accumulator, and extraction function 26 | 27 | This allows the 'Applicative' instance to assemble derived folds that 28 | traverse a stream only once 29 | 30 | A @('Fold' a b)@ processes elements of type @\'a\'@ and results in a 31 | value of type @\'b\'@. 32 | 33 | This is almost identical to @"Control.Foldl".'Control.Foldl.Fold'@ except 34 | with a `Serialize` constraint on the accumulator so that the `Fold`'s 35 | progress can be persisted. 36 | -} 37 | data Fold a b = forall x . Serialize x => Fold (x -> a -> x) x (x -> b) 38 | 39 | instance Functor (Fold a) where 40 | fmap f (Fold step begin done) = Fold step begin (f . done) 41 | {-# INLINABLE fmap #-} 42 | 43 | instance Profunctor Fold where 44 | lmap f (Fold step begin done) = Fold step' begin done 45 | where 46 | step' x a = step x (f a) 47 | {-# INLINABLE lmap #-} 48 | 49 | rmap = fmap 50 | {-# INLINABLE rmap #-} 51 | 52 | instance Comonad (Fold a) where 53 | extract (Fold _ begin done) = done begin 54 | {-# INLINABLE extract #-} 55 | 56 | duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done) 57 | {-# INLINABLE duplicate #-} 58 | 59 | instance Applicative (Fold a) where 60 | pure b = Fold (\() _ -> ()) () (\() -> b) 61 | {-# INLINABLE pure #-} 62 | 63 | (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = 64 | let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) 65 | begin = Pair beginL beginR 66 | done (Pair xL xR) = doneL xL (doneR xR) 67 | in Fold step begin done 68 | {-# INLINABLE (<*>) #-} 69 | 70 | instance Monoid b => Monoid (Fold a b) where 71 | mempty = pure mempty 72 | {-# INLINABLE mempty #-} 73 | 74 | mappend = liftA2 mappend 75 | {-# INLINABLE mappend #-} 76 | 77 | instance Num b => Num (Fold a b) where 78 | fromInteger = pure . fromInteger 79 | {-# INLINABLE fromInteger #-} 80 | 81 | negate = fmap negate 82 | {-# INLINABLE negate #-} 83 | 84 | abs = fmap abs 85 | {-# INLINABLE abs #-} 86 | 87 | signum = fmap signum 88 | {-# INLINABLE signum #-} 89 | 90 | (+) = liftA2 (+) 91 | {-# INLINABLE (+) #-} 92 | 93 | (*) = liftA2 (*) 94 | {-# INLINABLE (*) #-} 95 | 96 | (-) = liftA2 (-) 97 | {-# INLINABLE (-) #-} 98 | 99 | instance Fractional b => Fractional (Fold a b) where 100 | fromRational = pure . fromRational 101 | {-# INLINABLE fromRational #-} 102 | 103 | recip = fmap recip 104 | {-# INLINABLE recip #-} 105 | 106 | (/) = liftA2 (/) 107 | {-# INLINABLE (/) #-} 108 | 109 | instance Floating b => Floating (Fold a b) where 110 | pi = pure pi 111 | {-# INLINABLE pi #-} 112 | 113 | exp = fmap exp 114 | {-# INLINABLE exp #-} 115 | 116 | sqrt = fmap sqrt 117 | {-# INLINABLE sqrt #-} 118 | 119 | log = fmap log 120 | {-# INLINABLE log #-} 121 | 122 | sin = fmap sin 123 | {-# INLINABLE sin #-} 124 | 125 | tan = fmap tan 126 | {-# INLINABLE tan #-} 127 | 128 | cos = fmap cos 129 | {-# INLINABLE cos #-} 130 | 131 | asin = fmap sin 132 | {-# INLINABLE asin #-} 133 | 134 | atan = fmap atan 135 | {-# INLINABLE atan #-} 136 | 137 | acos = fmap acos 138 | {-# INLINABLE acos #-} 139 | 140 | sinh = fmap sinh 141 | {-# INLINABLE sinh #-} 142 | 143 | tanh = fmap tanh 144 | {-# INLINABLE tanh #-} 145 | 146 | cosh = fmap cosh 147 | {-# INLINABLE cosh #-} 148 | 149 | asinh = fmap asinh 150 | {-# INLINABLE asinh #-} 151 | 152 | atanh = fmap atanh 153 | {-# INLINABLE atanh #-} 154 | 155 | acosh = fmap acosh 156 | {-# INLINABLE acosh #-} 157 | 158 | (**) = liftA2 (**) 159 | {-# INLINABLE (**) #-} 160 | 161 | logBase = liftA2 logBase 162 | {-# INLINABLE logBase #-} 163 | 164 | data Pair a b = Pair !a !b 165 | 166 | instance (Serialize a, Serialize b) => Serialize (Pair a b) where 167 | put (Pair a b) = do 168 | put a 169 | put b 170 | {-# INLiNABLE put #-} 171 | 172 | get = do 173 | a <- get 174 | b <- get 175 | return (Pair a b) 176 | {-# INLINABLE get #-} 177 | 178 | -- | A strict 'Maybe' 179 | data Maybe' a = Just' !a | Nothing' 180 | 181 | instance Serialize a => Serialize (Maybe' a) where 182 | put x = put (lazyMaybe x) 183 | {-# INLINABLE put #-} 184 | 185 | get = fmap strictMaybe get 186 | {-# INLINABLE get #-} 187 | 188 | -- | Convert 'Maybe'' to 'Maybe' 189 | lazyMaybe :: Maybe' a -> Maybe a 190 | lazyMaybe Nothing' = Nothing 191 | lazyMaybe (Just' a) = Just a 192 | {-# INLINABLE lazyMaybe #-} 193 | 194 | -- | Convert 'Maybe' to 'Maybe'' 195 | strictMaybe :: Maybe a -> Maybe' a 196 | strictMaybe Nothing = Nothing' 197 | strictMaybe (Just a ) = Just' a 198 | {-# INLINABLE strictMaybe #-} 199 | 200 | -- | A strict 'Either' 201 | data Either' a b = Left' !a | Right' !b 202 | 203 | instance (Serialize a, Serialize b) => Serialize (Either' a b) where 204 | put x = put (lazyEither x) 205 | {-# INLINABLE put #-} 206 | 207 | get = fmap strictEither get 208 | {-# INLINABLE get #-} 209 | 210 | -- | Convert 'Either'' to 'Either' 211 | lazyEither :: Either' a b -> Either a b 212 | lazyEither (Left' a) = Left a 213 | lazyEither (Right' b) = Right b 214 | {-# INLINABLE lazyEither #-} 215 | 216 | -- | Convert 'Either' to 'Either'' 217 | strictEither :: Either a b -> Either' a b 218 | strictEither (Left a) = Left' a 219 | strictEither (Right b) = Right' b 220 | {-# INLINABLE strictEither #-} 221 | 222 | -- | Convert 'Either'' to 'Maybe' 223 | hush :: Either' a b -> Maybe b 224 | hush (Left' _) = Nothing 225 | hush (Right' b) = Just b 226 | {-# INLINABLE hush #-} 227 | 228 | -- | Apply a strict left 'Fold' to a 'Foldable' container 229 | fold :: Foldable f => Fold a b -> f a -> b 230 | fold (Fold step begin done) as = Data.Foldable.foldr cons done as begin 231 | where 232 | cons a k x = k $! step x a 233 | {-# INLINE fold #-} 234 | 235 | {-| A handler for the upstream input of a `Fold` 236 | 237 | Any lens, traversal, or prism will type-check as a `Handler` 238 | -} 239 | type Handler a b = 240 | forall x . (b -> Constant (Endo x) b) -> a -> Constant (Endo x) a 241 | 242 | {-| @(handles t folder)@ transforms the input of a `Fold` using a lens, 243 | traversal, or prism: 244 | 245 | > handles _1 :: Fold a r -> Fold (a, b) r 246 | > handles _Left :: Fold a r -> Fold (Either a b) r 247 | > handles traverse :: Traversable t => Fold a r -> Fold (t a) r 248 | 249 | >>> fold (handles traverse sum) [[1..5],[6..10]] 250 | 55 251 | 252 | >>> fold (handles (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] 253 | 42 254 | 255 | >>> fold (handles (filtered even) sum) [1,3,5,7,21,21] 256 | 42 257 | 258 | >>> fold (handles _2 mconcat) [(1,"Hello "),(2,"World"),(3,"!")] 259 | "Hello World!" 260 | 261 | > handles id = id 262 | > 263 | > handles (f . g) = handles f . handles g 264 | 265 | > handles t (pure r) = pure r 266 | > 267 | > handles t (f <*> x) = handles t f <*> handles t x 268 | -} 269 | handles :: Handler a b -> Fold b r -> Fold a r 270 | handles k (Fold step begin done) = Fold step' begin done 271 | where 272 | step' = flip (appEndo . getConstant . k (Constant . Endo . flip step)) 273 | {-# INLINABLE handles #-} 274 | 275 | -- | Fold all values within a container using 'mappend' and 'mempty' 276 | mconcat :: (Monoid a, Serialize a) => Fold a a 277 | mconcat = Fold mappend mempty id 278 | {-# INLINABLE mconcat #-} 279 | 280 | -- | Convert a \"@foldMap@\" to a 'Fold' 281 | foldMap :: (Monoid w, Serialize w) => (a -> w) -> (w -> b) -> Fold a b 282 | foldMap to = Fold (\x a -> mappend x (to a)) mempty 283 | {-# INLINABLE foldMap #-} 284 | 285 | {-| Get the first element of a container or return 'Nothing' if the container is 286 | empty 287 | -} 288 | head :: Serialize a => Fold a (Maybe a) 289 | head = _Fold1 const 290 | {-# INLINABLE head #-} 291 | 292 | {-| Get the last element of a container or return 'Nothing' if the container is 293 | empty 294 | -} 295 | last :: Serialize a => Fold a (Maybe a) 296 | last = _Fold1 (flip const) 297 | {-# INLINABLE last #-} 298 | 299 | {-| Get the last element of a container or return a default value if the container 300 | is empty 301 | -} 302 | lastDef :: Serialize a => a -> Fold a a 303 | lastDef a = Fold (\_ a' -> a') a id 304 | {-# INLINABLE lastDef #-} 305 | 306 | -- | Return the last N elements 307 | lastN :: Serialize a => Int -> Fold a [a] 308 | lastN n = Fold step begin done 309 | where 310 | step s a = s' |> a 311 | where 312 | s' = 313 | if Data.Sequence.length s < n 314 | then s 315 | else Data.Sequence.drop 1 s 316 | begin = Data.Sequence.empty 317 | done = Data.Foldable.toList 318 | {-# INLINABLE lastN #-} 319 | 320 | -- | Returns 'True' if the container is empty, 'False' otherwise 321 | null :: Fold a Bool 322 | null = Fold (\_ _ -> False) True id 323 | {-# INLINABLE null #-} 324 | 325 | -- | Return the length of the container 326 | length :: Fold a Int 327 | length = genericLength 328 | {- Technically, 'length' is just 'genericLength' specialized to 'Int's. I keep 329 | the two separate so that I can later provide an 'Int'-specialized 330 | implementation of 'length' for performance reasons like "GHC.List" does 331 | without breaking backwards compatibility. 332 | -} 333 | {-# INLINABLE length #-} 334 | 335 | -- | Returns 'True' if all elements are 'True', 'False' otherwise 336 | and :: Fold Bool Bool 337 | and = Fold (&&) True id 338 | {-# INLINABLE and #-} 339 | 340 | -- | Returns 'True' if any element is 'True', 'False' otherwise 341 | or :: Fold Bool Bool 342 | or = Fold (||) False id 343 | {-# INLINABLE or #-} 344 | 345 | {-| @(all predicate)@ returns 'True' if all elements satisfy the predicate, 346 | 'False' otherwise 347 | -} 348 | all :: (a -> Bool) -> Fold a Bool 349 | all predicate = Fold (\x a -> x && predicate a) True id 350 | {-# INLINABLE all #-} 351 | 352 | {-| @(any predicate)@ returns 'True' if any element satisfies the predicate, 353 | 'False' otherwise 354 | -} 355 | any :: (a -> Bool) -> Fold a Bool 356 | any predicate = Fold (\x a -> x || predicate a) False id 357 | {-# INLINABLE any #-} 358 | 359 | -- | Computes the sum of all elements 360 | sum :: (Num a, Serialize a) => Fold a a 361 | sum = Fold (+) 0 id 362 | {-# INLINABLE sum #-} 363 | 364 | -- | Computes the product all elements 365 | product :: (Num a, Serialize a) => Fold a a 366 | product = Fold (*) 1 id 367 | {-# INLINABLE product #-} 368 | 369 | -- | Computes the maximum element 370 | maximum :: (Ord a, Serialize a) => Fold a (Maybe a) 371 | maximum = _Fold1 max 372 | {-# INLINABLE maximum #-} 373 | 374 | -- | Computes the minimum element 375 | minimum :: (Ord a, Serialize a) => Fold a (Maybe a) 376 | minimum = _Fold1 min 377 | {-# INLINABLE minimum #-} 378 | 379 | {-| @(elem a)@ returns 'True' if the container has an element equal to @a@, 380 | 'False' otherwise 381 | -} 382 | elem :: Eq a => a -> Fold a Bool 383 | elem a = any (a ==) 384 | {-# INLINABLE elem #-} 385 | 386 | {-| @(notElem a)@ returns 'False' if the container has an element equal to @a@, 387 | 'True' otherwise 388 | -} 389 | notElem :: Eq a => a -> Fold a Bool 390 | notElem a = all (a /=) 391 | {-# INLINABLE notElem #-} 392 | 393 | {-| @(find predicate)@ returns the first element that satisfies the predicate or 394 | 'Nothing' if no element satisfies the predicate 395 | -} 396 | find :: Serialize a => (a -> Bool) -> Fold a (Maybe a) 397 | find predicate = Fold step Nothing' lazyMaybe 398 | where 399 | step x a = case x of 400 | Nothing' -> if predicate a then Just' a else Nothing' 401 | _ -> x 402 | {-# INLINABLE find #-} 403 | 404 | {-| @(index n)@ returns the @n@th element of the container, or 'Nothing' if the 405 | container has an insufficient number of elements 406 | -} 407 | index :: Serialize a => Int -> Fold a (Maybe a) 408 | index = genericIndex 409 | {-# INLINABLE index #-} 410 | 411 | {-| @(elemIndex a)@ returns the index of the first element that equals @a@, or 412 | 'Nothing' if no element matches 413 | -} 414 | elemIndex :: Eq a => a -> Fold a (Maybe Int) 415 | elemIndex a = findIndex (a ==) 416 | {-# INLINABLE elemIndex #-} 417 | 418 | {-| @(findIndex predicate)@ returns the index of the first element that 419 | satisfies the predicate, or 'Nothing' if no element satisfies the predicate 420 | -} 421 | findIndex :: (a -> Bool) -> Fold a (Maybe Int) 422 | findIndex predicate = Fold step (Left' 0) hush 423 | where 424 | step x a = case x of 425 | Left' i -> 426 | if predicate a 427 | then Right' i 428 | else Left' (i + 1) 429 | _ -> x 430 | {-# INLINABLE findIndex #-} 431 | 432 | -- | Like 'length', except with a more general 'Num' return value 433 | genericLength :: (Num b, Serialize b) => Fold a b 434 | genericLength = Fold (\n _ -> n + 1) 0 id 435 | {-# INLINABLE genericLength #-} 436 | 437 | -- | Like 'index', except with a more general 'Integral' argument 438 | genericIndex :: (Integral i, Serialize i, Serialize a) => i -> Fold a (Maybe a) 439 | genericIndex i = Fold step (Left' 0) done 440 | where 441 | step x a = case x of 442 | Left' j -> if i == j then Right' a else Left' (j + 1) 443 | _ -> x 444 | done x = case x of 445 | Left' _ -> Nothing 446 | Right' a -> Just a 447 | {-# INLINABLE genericIndex #-} 448 | 449 | {-| @_Fold1 step@ returns a new 'Fold' using just a step function that has the 450 | same type for the accumulator and the element. The result type is the 451 | accumulator type wrapped in 'Maybe'. The initial accumulator is retrieved from 452 | the 'Foldable', the result is 'None' for empty containers. 453 | -} 454 | _Fold1 :: Serialize a => (a -> a -> a) -> Fold a (Maybe a) 455 | _Fold1 step = Fold step_ Nothing' lazyMaybe 456 | where 457 | step_ mx a = Just' (case mx of 458 | Nothing' -> a 459 | Just' x -> step x a) 460 | 461 | {-| 462 | 463 | The first argument to `eventSource` must obey the following property: 464 | 465 | > f n = f 0 >-> Pipes.Prelude.drop n 466 | 467 | In other words, @f n@ must seek to the @n@th element of the event log 468 | -} 469 | eventSource 470 | :: (Integer -> Managed (Producer a IO r)) 471 | -- ^ Function to seek to an offset in the event log 472 | -> FilePath 473 | -- ^ File to persist the `Fold`'s state 474 | -> Integer 475 | -- ^ How many events between each checkpoint 476 | -> Fold a b 477 | -- ^ Derived result(s) to compute 478 | -> Managed (Producer b IO r) 479 | -- ^ Result stream 480 | eventSource acquireEventLog path numEvents userFold = 481 | case liftA2 (,) genericLength userFold of 482 | Fold step begin done -> do 483 | 484 | exists <- liftIO (System.Directory.doesFileExist path) 485 | begin' <- liftIO (do 486 | if exists 487 | then do 488 | bytes <- ByteString.readFile path 489 | case Serialize.decode bytes of 490 | Left str -> throwIO (userError str) 491 | Right begin' -> return begin' 492 | else return begin ) 493 | 494 | let (offset, _) = done begin' 495 | 496 | let scan x = do 497 | let (n, b) = done x 498 | if n `rem` numEvents == 0 499 | then liftIO (ByteString.writeFile path (Serialize.encode x)) 500 | else return () 501 | yield b 502 | e <- await 503 | scan $! step x e 504 | 505 | eventLog <- acquireEventLog offset 506 | return (eventLog >-> scan begin') 507 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-5.2 2 | packages: 3 | - . 4 | --------------------------------------------------------------------------------