├── .gitignore ├── README.md ├── lambda-bus ├── .gitignore ├── LICENSE.md ├── README.md ├── Setup.hs ├── benchmark │ └── Main.hs ├── library │ └── Lambda │ │ ├── Bus.hs │ │ └── Bus │ │ ├── Impl.hs │ │ └── Types.hs ├── package.yaml └── test-suite │ └── Main.hs ├── lambda-client ├── .gitignore ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.hs ├── benchmark │ └── Main.hs ├── executable │ └── Main.hs ├── library │ └── Lambda │ │ ├── Client.hs │ │ └── Client │ │ ├── Connection.hs │ │ ├── EndPoint.hs │ │ ├── Messages.hs │ │ ├── Operation.hs │ │ ├── Settings.hs │ │ └── TcpConnection.hs ├── package.yaml └── test-suite │ └── Main.hs ├── lambda-logger ├── .gitignore ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.hs ├── library │ └── Lambda │ │ └── Logger.hs ├── package.yaml └── stack.yaml ├── lambda-node ├── .gitignore ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.hs ├── benchmark │ └── Main.hs ├── executable │ └── Main.hs ├── library │ └── Lambda │ │ ├── Node.hs │ │ └── Node │ │ ├── Index.hs │ │ ├── Journal.hs │ │ ├── Manager │ │ ├── Connection.hs │ │ └── Operation.hs │ │ ├── Monitoring.hs │ │ └── Settings.hs ├── package.yaml ├── stack.yaml └── test-suite │ └── Main.hs ├── lambda-prelude ├── .gitignore ├── LICENSE.md ├── README.md ├── Setup.hs ├── library │ └── Lambda │ │ ├── Prelude.hs │ │ └── Prelude │ │ ├── Duration.hs │ │ └── Stopwatch.hs ├── package.yaml ├── stack.yaml └── test-suite │ └── Main.hs ├── lambda-protocol ├── .gitignore ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.hs ├── library │ └── Protocol │ │ ├── Message.hs │ │ ├── Message │ │ ├── EventRecord.hs │ │ ├── ReadEvents.hs │ │ └── WriteEvents.hs │ │ ├── Operation.hs │ │ ├── Package.hs │ │ └── Types.hs ├── package.yaml ├── stack.yaml └── test-suite │ ├── Main.hs │ └── Test │ ├── Common.hs │ └── Serialize.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | trash/ 2 | .stack-work/ 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lambda Database Experiment (LDE) 2 | 3 | Experimental event store database entirely written in Haskell. The main goal is learning. Database programming is full of interesting algorithms and challenges. There is no plan for going production ready but it will be definitely cool if 4 | it happens someday. 5 | 6 | This project is comprised of: 7 | * **lambda-bus**: In-memory message bus. It's used in **lambda-node** and **lambda-client** and helps to implement a **S**taged **E**vent-**D**riven **A**rchitecture. 8 | * **lambda-client**: TCP client of **lambda-node**. 9 | * **lambda-logger**: Logging infrastructure used by **lambda-bus**, **lambda-client**, **lambda-node** and **lambda-prelude**. 10 | * **lambda-node**: Eventstore database server. 11 | * **lambda-prelude**: A prelude specific to **LDE** project. 12 | * **lambda-protocol**: Gathers all the type declarations common to **lambda-client** and **lambda-node**. 13 | 14 | ## How to build this project ? 15 | 16 | This project assumes a 64bits Unix system and the build tool [stack][] installed. The project is developped mainly on Mac OSX and Linux based distributions. For now, nothing prevents the project from being built on Windows. That being said, Windows will **never** be officially supported. 17 | 18 | To build the entire project: 19 | 20 | ``` 21 | $ stack build 22 | ``` 23 | 24 | You can also build a specific package by appending its name to the build command. 25 | 26 | ``` 27 | $ stack build lambda-node 28 | ``` 29 | 30 | ## Notes 31 | 32 | Contributions and bug reports are welcome! 33 | 34 | MIT License 35 | 36 | -Yorick Laupa 37 | 38 | [stack]: http://haskellstack.org 39 | -------------------------------------------------------------------------------- /lambda-bus/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-bus/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-bus/README.md: -------------------------------------------------------------------------------- 1 | # lambda-bus 2 | 3 | In-memory message bus. 4 | -------------------------------------------------------------------------------- /lambda-bus/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-bus/benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | -- You can benchmark your code quickly and effectively with Criterion. See its 2 | -- website for help: . 3 | import Criterion.Main 4 | 5 | main :: IO () 6 | main = defaultMain [bench "const" (whnf const ())] 7 | -------------------------------------------------------------------------------- /lambda-bus/library/Lambda/Bus.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Bus 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Lambda.Bus 12 | ( module Lambda.Bus.Impl 13 | , module Lambda.Bus.Types 14 | ) where 15 | 16 | -------------------------------------------------------------------------------- 17 | import Lambda.Bus.Impl 18 | import Lambda.Bus.Types 19 | -------------------------------------------------------------------------------- /lambda-bus/library/Lambda/Bus/Impl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Lambda.Bus.Impl 7 | -- Copyright : (C) 2017 Yorick Laupa 8 | -- License : (see the file LICENSE) 9 | -- Maintainer: Yorick Laupa 10 | -- Stability : experimental 11 | -- Portability: non-portable 12 | -- 13 | -- In-memory message bus implementation. This implementation also provides 14 | -- tree-like organisation. A bus could have children and also one parent. 15 | -- 16 | -- When a bus receive a message but has no registered callbacks for it, it 17 | -- propagates that message to its parent. That procedure stops as soon as 18 | -- a callbacks can support the message or there is parent to reach out. 19 | -------------------------------------------------------------------------------- 20 | module Lambda.Bus.Impl where 21 | 22 | -------------------------------------------------------------------------------- 23 | import Data.Typeable 24 | 25 | -------------------------------------------------------------------------------- 26 | import Lambda.Logger 27 | import Lambda.Prelude 28 | 29 | -------------------------------------------------------------------------------- 30 | import Lambda.Bus.Types 31 | 32 | -------------------------------------------------------------------------------- 33 | type Callbacks settings = HashMap Type (Seq (Callback settings)) 34 | 35 | -------------------------------------------------------------------------------- 36 | -- | An in-memory message bus. 37 | data Bus settings = 38 | Bus { _busEventHandlers :: TVar (Callbacks settings) 39 | -- ^ All registered callbacks. 40 | , _busQueue :: TBMQueue Message 41 | -- ^ Actual message queue. 42 | , _busChildren :: TVar (HashMap UUID (Bus settings)) 43 | -- ^ Bus children. 44 | , _busParent :: TVar (Maybe (Bus settings)) 45 | -- ^ Bus parent. 46 | , _workerAsync :: Async () 47 | -- ^ Worker thread handle. 48 | , _busId :: UUID 49 | -- ^ Bus id. 50 | } 51 | 52 | -------------------------------------------------------------------------------- 53 | -- | Stops 'Bus'. 54 | _busStop :: Bus settings -> Lambda settings () 55 | _busStop Bus{..} = atomically $ do 56 | closeTBMQueue _busQueue 57 | parent <- readTVar _busParent 58 | for_ parent $ \p -> 59 | busDeleteChildSTM p _busId 60 | 61 | -------------------------------------------------------------------------------- 62 | -- | Set a 'Bus' parent. 63 | busParent :: Bus settings -> Bus settings -> Lambda settings () 64 | busParent Bus{..} parent = atomically $ writeTVar _busParent (Just parent) 65 | 66 | -------------------------------------------------------------------------------- 67 | -- | Waits until a 'Bus' has stopped and carried out all its messages. 68 | busProcessedEverything :: MonadIO m => Bus settings -> m () 69 | busProcessedEverything Bus{..} = waitAsync _workerAsync 70 | 71 | -------------------------------------------------------------------------------- 72 | -- | Creates a new child bus. 73 | busNewChild :: Bus s -> Lambda s (Bus s) 74 | busNewChild self = do 75 | child <- newBus 76 | busInsertChild self child 77 | return child 78 | 79 | -------------------------------------------------------------------------------- 80 | -- | Insert a bus as a child. 81 | busInsertChild :: Bus settings -- Parent. 82 | -> Bus settings -- Child. 83 | -> Lambda settings () 84 | busInsertChild self child = do 85 | atomically $ modifyTVar' (_busChildren self) (insertMap (_busId child) child) 86 | busParent child self 87 | 88 | -------------------------------------------------------------------------------- 89 | -- | Remove a bus as child given its id. 90 | busDeleteChildSTM :: Bus settings -> UUID -> STM () 91 | busDeleteChildSTM Bus{..} childId = modifyTVar' _busChildren (deleteMap childId) 92 | 93 | -------------------------------------------------------------------------------- 94 | -- | Creates a new 'Bus'. 95 | newBus :: Lambda settings (Bus settings) 96 | newBus = do 97 | bus <- mfix $ \self -> 98 | Bus <$> (liftIO $ newTVarIO mempty) 99 | <*> (liftIO $ newTBMQueueIO mailboxLimit) 100 | <*> (liftIO $ newTVarIO mempty) 101 | <*> (liftIO $ newTVarIO Nothing) 102 | <*> async (worker self) 103 | <*> freshUUID 104 | 105 | configure bus configureTimer 106 | return bus 107 | where 108 | mailboxLimit = 500 109 | 110 | -------------------------------------------------------------------------------- 111 | -- | Configures a 'Bus' with the help of a 'Configure' computation. 112 | configure :: Bus settings -> Configure settings () -> Lambda settings () 113 | configure self conf = runConfigure conf self 114 | 115 | -------------------------------------------------------------------------------- 116 | -- | 'Bus' worker thread. 117 | worker :: Bus settings -> Lambda settings () 118 | worker self@Bus{..} = loop 119 | where 120 | handleMsg msg = do 121 | callbacks <- atomically $ readTVar _busEventHandlers 122 | publishing self callbacks msg 123 | loop 124 | 125 | loop = traverse_ handleMsg =<< atomically (readTBMQueue _busQueue) 126 | 127 | -------------------------------------------------------------------------------- 128 | instance PubSub Bus where 129 | subscribeSTM Bus{..} hdl@(Callback prx _) = 130 | modifyTVar' _busEventHandlers update 131 | where update callbacks = 132 | let 133 | tpe = getType (FromProxy prx) 134 | 135 | next = alterMap $ \input -> 136 | case input of 137 | Nothing -> 138 | Just (singleton hdl) 139 | 140 | Just hs -> 141 | Just (snoc hs hdl) 142 | in 143 | next tpe callbacks 144 | 145 | publishSTM Bus{..} msg = 146 | do closed <- isClosedTBMQueue _busQueue 147 | writeTBMQueue _busQueue msg 148 | return $ not closed 149 | 150 | busId = _busId 151 | busStop = _busStop 152 | 153 | -------------------------------------------------------------------------------- 154 | -- | Publishes a message. First it determines if the message is routed. Meaning 155 | -- if the message has proper target known by its children. If yes, then the 156 | -- message is dispatched to the right child. Otherwise, it tries to dispatch 157 | -- the message to the right handler if it exists. This implementation also 158 | -- propagating the message to handler that support 'Message' if those exists. 159 | publishing :: Bus settings 160 | -> Callbacks settings 161 | -> Message 162 | -> Lambda settings () 163 | publishing self@Bus{..} callbacks msg@(Message a _ destM) = 164 | unlessM (atomically routedSTM) $ 165 | do let tpe = getType (FromTypeable a) 166 | handlers = lookup tpe callbacks 167 | 168 | logDebug [i|Publishing message #{tpe}.|] 169 | traverse_ (propagate self a) handlers 170 | 171 | -- If there is no handlers this type of event, we try to dispatch it to 172 | -- its parent bus, if any. 173 | unless (isJust handlers) $ 174 | do parentM <- liftIO $ readTVarIO _busParent 175 | for_ parentM $ \parent -> 176 | void $ atomically $ publishSTM parent msg 177 | 178 | logDebug [i|Message #{tpe} propagated.|] 179 | 180 | traverse_ (propagate self msg) (lookup messageType callbacks) 181 | where 182 | routedSTM = 183 | do children <- readTVar _busChildren 184 | let known = destM >>= \dest -> lookup dest children 185 | case known of 186 | Just child -> 187 | let newMsg = msg { messageTarget = Nothing } 188 | in True <$ publishSTM child newMsg 189 | Nothing -> return False 190 | 191 | -------------------------------------------------------------------------------- 192 | -- | Runs every callbacks in order by submitting the message to them. 193 | propagate :: Typeable a => Bus s -> a -> Seq (Callback s) -> Lambda s () 194 | propagate self@Bus{..} a = traverse_ $ \(Callback _ k) -> do 195 | let Just b = cast a 196 | tpe = typeOf b 197 | outcome <- tryAny $ runReact (k b) reactEnv 198 | case outcome of 199 | Right _ -> return () 200 | Left e -> logError [i|Exception when propagating #{tpe}: #{e}.|] 201 | where 202 | reactEnv = 203 | ReactEnv { _reactBus = toSomeBus self 204 | , _reactSelf = _busId 205 | , _reactSender = Nothing 206 | } 207 | -------------------------------------------------------------------------------- /lambda-bus/library/Lambda/Bus/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Lambda.Bus.Types 9 | -- Copyright : (C) 2017 Yorick Laupa 10 | -- License : (see the file LICENSE) 11 | -- 12 | -- Maintainer : Yorick Laupa 13 | -- Stability : provisional 14 | -- Portability : non-portable 15 | -- 16 | -- Main Bus types declaration module. 17 | -------------------------------------------------------------------------------- 18 | module Lambda.Bus.Types where 19 | 20 | -------------------------------------------------------------------------------- 21 | import Data.Semigroup 22 | import Data.Typeable 23 | import GHC.Fingerprint 24 | import Lambda.Prelude 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Message sent and received by a bus. It also contains information that helps 28 | -- its routing. 29 | data Message = 30 | forall payload. Typeable payload => 31 | Message { messagePayload :: !payload 32 | -- ^ True message sent or received by a message bus. 33 | , messageSender :: !UUID 34 | -- ^ Who sent this message. 35 | , messageTarget :: !(Maybe UUID) 36 | -- ^ Who is targetted by this message. If 'Nothing', then the 37 | -- message bus sends it to itself. 38 | } 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Returns the type representation of a 'Message'. 42 | getMessageType :: Message -> Type 43 | getMessageType (Message p _ _) = getType (FromTypeable p) 44 | 45 | -------------------------------------------------------------------------------- 46 | instance Show Message where 47 | show (Message a _ _) = "Message: " <> show (typeOf a) 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Returns a typeful representation of a 'Message'. If the wrong message type is 51 | -- asked, it returns 'Nothing'. 52 | fromMsg :: Typeable a => Message -> Maybe a 53 | fromMsg (Message a _ _) = cast a 54 | 55 | -------------------------------------------------------------------------------- 56 | -- Used to correlate a message type to its reaction callback. 57 | data Callback settings where 58 | Callback :: Typeable a 59 | => Proxy a 60 | -> (a -> React settings ()) 61 | -> Callback settings 62 | 63 | -------------------------------------------------------------------------------- 64 | instance Show (Callback settings) where 65 | show (Callback prx _) = "Callback expects " <> show (typeRep prx) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Message bus abstraction. 69 | class PubSub p where 70 | -- | Subscribes to a specific message. 71 | subscribeSTM :: p s -> Callback s -> STM () 72 | 73 | -- | Publishes a message to the message bus. 74 | publishSTM :: p s -> Message -> STM Bool 75 | 76 | -- | Returns message bus unique id. 77 | busId :: p s -> UUID 78 | 79 | -- | Stops a message bus. After that call, a message bus can no longer 80 | -- accepts new subscription nor incoming message. 81 | busStop :: p s -> Lambda s () 82 | 83 | -- | Returns a existentially type representation of a message bus. 84 | toSomeBus :: p s -> SomeBus s 85 | toSomeBus = SomeBus 86 | 87 | -------------------------------------------------------------------------------- 88 | -- | Parent type of all message bus. 89 | data SomeBus s = forall p. PubSub p => SomeBus (p s) 90 | 91 | -------------------------------------------------------------------------------- 92 | instance PubSub SomeBus where 93 | subscribeSTM (SomeBus p) c = subscribeSTM p c 94 | publishSTM (SomeBus p) a = publishSTM p a 95 | busId (SomeBus p) = busId p 96 | busStop (SomeBus p) = busStop p 97 | toSomeBus = id 98 | 99 | -------------------------------------------------------------------------------- 100 | -- | A type representation helping when casting a 'Message'. 101 | data Type = Type TypeRep Fingerprint 102 | 103 | -------------------------------------------------------------------------------- 104 | instance Show Type where 105 | show (Type rep _) = "type " <> show rep 106 | 107 | -------------------------------------------------------------------------------- 108 | instance Eq Type where 109 | Type _ a == Type _ b = a == b 110 | 111 | -------------------------------------------------------------------------------- 112 | instance Ord Type where 113 | compare (Type _ a) (Type _ b) = compare a b 114 | 115 | -------------------------------------------------------------------------------- 116 | instance Hashable Type where 117 | hashWithSalt s (Type _ (Fingerprint b l)) = hashWithSalt s (b, l) 118 | 119 | -------------------------------------------------------------------------------- 120 | -- | Represents the different ways of getting a 'Type' representation. 121 | data GetType 122 | = forall a. Typeable a => FromTypeable a 123 | | forall prx a. Typeable a => FromProxy (prx a) 124 | 125 | -------------------------------------------------------------------------------- 126 | -- | Returns a type representation. 127 | getType :: GetType -> Type 128 | getType op = Type t (typeRepFingerprint t) 129 | where 130 | t = case op of 131 | FromTypeable a -> typeOf a 132 | FromProxy prx -> typeRep prx 133 | 134 | -------------------------------------------------------------------------------- 135 | -- | Type representation of a 'Message'. 136 | messageType :: Type 137 | messageType = getType (FromProxy (Proxy :: Proxy Message)) 138 | 139 | -------------------------------------------------------------------------------- 140 | -- | Environment used when serving a message to a message callback. 141 | data ReactEnv settings = 142 | ReactEnv { _reactBus :: !(SomeBus settings) 143 | -- ^ The bus which received the message. 144 | , _reactSelf :: !UUID 145 | -- ^ Id of the bus. 146 | , _reactSender :: !(Maybe UUID) 147 | -- ^ Who sends the message. If 'Nothing', it means the bus sends 148 | -- to itself. 149 | } 150 | 151 | -------------------------------------------------------------------------------- 152 | -- | Effect used when reacting to an incoming message. 153 | newtype React settings a = 154 | React { unReact :: ReaderT (ReactEnv settings) (Lambda settings) a } 155 | deriving ( Functor 156 | , Applicative 157 | , Monad 158 | , MonadIO 159 | , MonadFix 160 | , MonadThrow 161 | , MonadCatch 162 | , MonadLogger 163 | , MonadBase IO 164 | , MonadBaseControl IO 165 | ) 166 | 167 | -------------------------------------------------------------------------------- 168 | -- | Publishes a message to the same message queue. 169 | publish :: Typeable a => a -> React settings () 170 | publish a = React $ do 171 | ReactEnv{..} <- ask 172 | let msg = Message a _reactSelf Nothing 173 | _ <- atomically $ publishSTM _reactBus msg 174 | return () 175 | 176 | -------------------------------------------------------------------------------- 177 | -- | Responds to the sender of of the message who triggered this reaction. If 178 | -- there isn't a sender, it will act like 'publish'. 179 | respond :: Typeable a => a -> React settings () 180 | respond a = React $ do 181 | ReactEnv{..} <- ask 182 | let msg = Message a _reactSelf _reactSender 183 | _ <- atomically $ publishSTM _reactBus msg 184 | return () 185 | 186 | -------------------------------------------------------------------------------- 187 | -- | Publishes a message to a specific message bus. 188 | publishOn :: (Typeable a, PubSub p) 189 | => p settings -- Some bus. 190 | -> UUID -- Id of the sender. 191 | -> a -- message. 192 | -> Lambda settings () 193 | publishOn p sender a = void $ atomically $ publishSTM p msg 194 | where 195 | msg = Message a sender Nothing 196 | 197 | -------------------------------------------------------------------------------- 198 | -- | Like 'publishOn' but lifted in 'React' monad. 199 | sendTo :: (Typeable a, PubSub p) => p settings -> a -> React settings () 200 | sendTo bus evt = reactLambda $ publishOn bus (busId bus) evt 201 | 202 | -------------------------------------------------------------------------------- 203 | -- | Like 'busStop' but lifted in 'React' monad. 204 | stop :: React s () 205 | stop = React $ do 206 | bus <- asks _reactBus 207 | lift $ busStop bus 208 | 209 | -------------------------------------------------------------------------------- 210 | -- | Returns the settings of this application. 211 | reactSettings :: React settings settings 212 | reactSettings = React $ lift getSettings 213 | 214 | -------------------------------------------------------------------------------- 215 | -- | Runs 'React' monad with a proper environment. 216 | runReact :: React s a -> ReactEnv s -> Lambda s a 217 | runReact (React m) env = runReaderT m env 218 | 219 | -------------------------------------------------------------------------------- 220 | -- | Lift a 'Lambda' computation in 'React' monad. 221 | reactLambda :: Lambda s a -> React s a 222 | reactLambda m = React $ lift m 223 | 224 | -------------------------------------------------------------------------------- 225 | -- | Returns the id of the message bus. 226 | reactSelfId :: React settings UUID 227 | reactSelfId = React $ asks _reactSelf 228 | 229 | -------------------------------------------------------------------------------- 230 | -- | Returns the message bus. 231 | reactBus :: React settings (SomeBus settings) 232 | reactBus = React $ asks _reactBus 233 | 234 | -------------------------------------------------------------------------------- 235 | -- | Subscribes to a specific message type and uses the provided callback as a 236 | -- reaction. 237 | subscribe :: Typeable a => (a -> React s ()) -> Configure s () 238 | subscribe k = Configure $ do 239 | bus <- ask 240 | atomically $ subscribeSTM bus $ Callback Proxy k 241 | 242 | -------------------------------------------------------------------------------- 243 | -- | Computation used to configure a message bus. 244 | newtype Configure s a = 245 | Configure (ReaderT (SomeBus s) (Lambda s) a) 246 | deriving ( Functor 247 | , Applicative 248 | , Monad 249 | , MonadFix 250 | , MonadIO 251 | , MonadBase IO 252 | , MonadBaseControl IO 253 | ) 254 | 255 | -------------------------------------------------------------------------------- 256 | -- | Runs 'Configure' computation upon a message bus. 257 | runConfigure :: PubSub p => Configure s () -> p s -> Lambda s () 258 | runConfigure (Configure m) p = runReaderT m (toSomeBus p) 259 | 260 | -------------------------------------------------------------------------------- 261 | -- | Action to run after `Configure` computation completes. 262 | appStart :: React settings () -> Configure settings () 263 | appStart action = Configure $ do 264 | bus <- ask 265 | let reactEnv = 266 | ReactEnv bus (busId bus) Nothing 267 | lift $ runReact action reactEnv 268 | 269 | -------------------------------------------------------------------------------- 270 | -- | Configures a timer manager so it can receive timer requests. 271 | configureTimer :: Configure settings () 272 | configureTimer = do 273 | self <- TimerState <$> newIORef False 274 | subscribe (onRegisterTimer self) 275 | 276 | -------------------------------------------------------------------------------- 277 | -- | Sends a timer request. 278 | timer :: Typeable a 279 | => a -- Message to send back when time runs out. 280 | -> NominalDiffTime -- Time period before the timer runs out. 281 | -> TimerPlanning -- Timer strategy. 282 | -> Configure settings () 283 | timer e timespan planning = Configure $ do 284 | bus <- ask 285 | lift $ registerTimer bus e timespan planning 286 | 287 | -------------------------------------------------------------------------------- 288 | -- | A timer state. 289 | data TimerState = 290 | TimerState 291 | { _timerStopped :: IORef Bool } 292 | 293 | -------------------------------------------------------------------------------- 294 | -- | What is done when timer request is sent. 295 | onRegisterTimer :: TimerState -> RegisterTimer -> React settings () 296 | onRegisterTimer self (RegisterTimer evt duration oneOff) = 297 | delayed self evt duration oneOff 298 | 299 | -------------------------------------------------------------------------------- 300 | -- | Timer request. 301 | data RegisterTimer = 302 | forall e. Typeable e => RegisterTimer e NominalDiffTime Bool 303 | 304 | -------------------------------------------------------------------------------- 305 | -- | Tells if a timer request is a one time thing or must be repeated 306 | -- undefinitely. 307 | data TimerPlanning = OnOff | Undefinitely 308 | 309 | -------------------------------------------------------------------------------- 310 | -- | Emits a timer request. 311 | registerTimer :: (Typeable evt, PubSub p) 312 | => p settings 313 | -> evt 314 | -> NominalDiffTime 315 | -> TimerPlanning 316 | -> Lambda settings () 317 | registerTimer p evt period plan = 318 | publishOn p (busId p) (RegisterTimer evt period boolean) 319 | where boolean = 320 | case plan of 321 | OnOff -> 322 | True 323 | Undefinitely -> 324 | False 325 | 326 | -------------------------------------------------------------------------------- 327 | -- | Action run in a response of a timer request. 328 | delayed :: Typeable e 329 | => TimerState 330 | -> e 331 | -> NominalDiffTime 332 | -> Bool 333 | -> React settings () 334 | delayed TimerState{..} msg timespan oneOff = void $ fork loop 335 | where 336 | micros = truncate (timespan * s2mcs) 337 | loop = do 338 | threadDelay micros 339 | publish msg 340 | stopped <- readIORef _timerStopped 341 | unless (oneOff || stopped) loop 342 | 343 | -------------------------------------------------------------------------------- /lambda-bus/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | benchmarks: 5 | lambda-bus-benchmarks: 6 | dependencies: 7 | - base 8 | - lambda-bus 9 | - criterion 10 | ghc-options: 11 | - -rtsopts 12 | - -threaded 13 | - -with-rtsopts=-N 14 | main: Main.hs 15 | source-dirs: benchmark 16 | category: Other 17 | description: lambda-bus is a new Haskeleton package. 18 | extra-source-files: 19 | - LICENSE.md 20 | - package.yaml 21 | - README.md 22 | ghc-options: -Wall 23 | github: YoEight/lambda-bus 24 | 25 | default-extensions: 26 | - LambdaCase 27 | - NoImplicitPrelude 28 | - QuasiQuotes 29 | - RecordWildCards 30 | 31 | library: 32 | dependencies: 33 | - base 34 | - stm 35 | - mtl 36 | - hashable 37 | - monad-control 38 | - lambda-prelude 39 | - lambda-logger 40 | source-dirs: library 41 | license: MIT 42 | maintainer: Yorick Laupa 43 | name: lambda-bus 44 | synopsis: A new Haskeleton package. 45 | tests: 46 | lambda-bus-test-suite: 47 | dependencies: 48 | - base 49 | - lambda-bus 50 | - tasty 51 | - tasty-hspec 52 | ghc-options: 53 | - -rtsopts 54 | - -threaded 55 | - -with-rtsopts=-N 56 | main: Main.hs 57 | source-dirs: test-suite 58 | version: '0.0.0' 59 | -------------------------------------------------------------------------------- /lambda-bus/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -- Tasty makes it easy to test your code. It is a test framework that can 2 | -- combine many different types of tests into one suite. See its website for 3 | -- help: . 4 | import qualified Test.Tasty 5 | -- Hspec is one of the providers for Tasty. It provides a nice syntax for 6 | -- writing tests. Its website has more info: . 7 | import Test.Tasty.Hspec 8 | 9 | main :: IO () 10 | main = do 11 | test <- testSpec "lambda-bus" spec 12 | Test.Tasty.defaultMain test 13 | 14 | spec :: Spec 15 | spec = parallel $ do 16 | it "is trivially true" $ do 17 | True `shouldBe` True -------------------------------------------------------------------------------- /lambda-client/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-client/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | lambda-client uses [Semantic Versioning][]. 4 | The change log is available through the [releases on GitHub][]. 5 | 6 | [Semantic Versioning]: http://semver.org/spec/v2.0.0.html 7 | [releases on GitHub]: https://github.com/YoEight/lambda-client/releases 8 | -------------------------------------------------------------------------------- /lambda-client/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-client/README.md: -------------------------------------------------------------------------------- 1 | # lambda-client 2 | 3 | Provides an API to communicate with the database server. 4 | -------------------------------------------------------------------------------- /lambda-client/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-client/benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | -- You can benchmark your code quickly and effectively with Criterion. See its 2 | -- website for help: . 3 | import Criterion.Main 4 | 5 | main :: IO () 6 | main = defaultMain [bench "const" (whnf const ())] 7 | -------------------------------------------------------------------------------- /lambda-client/executable/Main.hs: -------------------------------------------------------------------------------- 1 | -- It is generally a good idea to keep all your business logic in your library 2 | -- and only use it in the executable. Doing so allows others to use what you 3 | -- wrote in their libraries. 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | 8 | import Lambda.Client 9 | 10 | main :: IO () 11 | main = do 12 | _ <- newClientWithDefault 13 | forever $ do 14 | threadDelay 1000000 15 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -- Client public API. 12 | -------------------------------------------------------------------------------- 13 | module Lambda.Client 14 | ( Client 15 | , WriteResult(..) 16 | , ReadStreamResult(..) 17 | , newClient 18 | , newClientWithDefault 19 | , awaitShutdown 20 | , writeEvents 21 | , readEvents 22 | , module Protocol.Types 23 | ) where 24 | 25 | -------------------------------------------------------------------------------- 26 | import Data.List.NonEmpty 27 | 28 | -------------------------------------------------------------------------------- 29 | import Lambda.Bus 30 | import Lambda.Prelude 31 | import Protocol.Operation 32 | import Protocol.Types hiding (streamName, eventNumber) 33 | 34 | -------------------------------------------------------------------------------- 35 | import qualified Lambda.Client.Connection as Connection 36 | import qualified Lambda.Client.Messages as Messages 37 | import Lambda.Client.Settings 38 | import Lambda.Client.TcpConnection 39 | 40 | -------------------------------------------------------------------------------- 41 | -- | Client connection reference. 42 | data Client = 43 | Client 44 | { _settings :: Settings 45 | -- ^ Connection settings. 46 | , _mainBus :: Bus Settings 47 | -- ^ Main message bus. 48 | } 49 | 50 | -------------------------------------------------------------------------------- 51 | -- | Creates a new connection to a single node. It maintains a full duplex 52 | -- connection to the database. A connection operates quite 53 | -- differently than say a SQL connection. You want to keep the connection open 54 | -- for a much longer of time than when you use a SQL connection. 55 | -- 56 | -- Another difference is all operations are handled in a full async manner 57 | -- (even if you call the synchronous behaviors). Many threads can use a 58 | -- connection at the same time or a single thread can make many asynchronous 59 | -- requests. To get the most performance out of the connection it is generally 60 | -- recommended to use it in this way. 61 | newClient :: Settings -> IO Client 62 | newClient setts = lambdaMain_ setts $ do 63 | mainBus <- newBus 64 | builder <- connectionBuilder 65 | 66 | configure mainBus (Connection.app builder) 67 | 68 | let client = Client setts mainBus 69 | return client 70 | 71 | -------------------------------------------------------------------------------- 72 | -- | Response you get when sending a write request to the server. 73 | data WriteResult = 74 | WriteResult 75 | { eventNumber :: !EventNumber 76 | -- ^ Next 'EventNumber' of the stream which performed the write. 77 | , result :: !WriteResultFlag 78 | -- ^ Write request outcome. 79 | } deriving Show 80 | 81 | -------------------------------------------------------------------------------- 82 | -- | Sends a write request. 83 | writeEvents :: Client 84 | -> StreamName 85 | -> NonEmpty Event 86 | -> ExpectedVersion 87 | -> IO (Async WriteResult) 88 | writeEvents self name events version = 89 | fmap (fmap convert) $ submitRequest self req 90 | where 91 | req = WriteEvents name version events 92 | 93 | convert (WriteEventsResp num flag) = 94 | WriteResult num flag 95 | 96 | -------------------------------------------------------------------------------- 97 | -- | Response you get when sending a read request to the server. 98 | data ReadStreamResult = 99 | ReadStreamResult 100 | { streamName :: !StreamName 101 | -- ^ The stream name where the read operation took place. 102 | , events :: ![SavedEvent] 103 | -- ^ Current batch of 'SavedEvent''s 104 | , flag :: !ReadResultFlag 105 | -- ^ Read request outcome. 106 | , nextEventNumber :: !EventNumber 107 | -- ^ Next 'EventNumber' to use if you want to read the next events. 108 | , endOfStream :: !Bool 109 | -- ^ If the end of stream has been reached. 110 | } deriving Show 111 | 112 | -------------------------------------------------------------------------------- 113 | -- | Sends a read request. 114 | readEvents :: Client -> StreamName -> Batch -> IO (Async ReadStreamResult) 115 | readEvents self name batch = 116 | fmap (fmap convert) $ submitRequest self req 117 | where 118 | req = ReadEvents name batch 119 | 120 | convert (ReadEventsResp n xs fl num eos) = 121 | ReadStreamResult n xs fl num eos 122 | 123 | -------------------------------------------------------------------------------- 124 | -- | Waits the 'Client' to carry out all its pending operations. 125 | awaitShutdown :: Client -> IO () 126 | awaitShutdown Client{..} = busProcessedEverything _mainBus 127 | 128 | -------------------------------------------------------------------------------- 129 | -- | Creates a 'Client' using 'defaultSettings'. 130 | newClientWithDefault :: IO Client 131 | newClientWithDefault = newClient defaultSettings 132 | 133 | -------------------------------------------------------------------------------- 134 | -- | Utility function to send asynchronous request. 135 | submitRequest :: Client -> Request a -> IO (Async a) 136 | submitRequest Client{..} req = do 137 | var <- newEmptyMVar 138 | let evt = Messages.NewRequest req (putMVar var) 139 | msg = Message 140 | { messagePayload = evt 141 | , messageSender = _busId _mainBus 142 | , messageTarget = Nothing 143 | } 144 | 145 | _ <- atomically $ publishSTM _mainBus msg 146 | async (either throwString pure =<< takeMVar var) 147 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/Connection.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client.Connection 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -- TCP Connection manager. That module goal is to create, maintain and request 11 | -- operations to the LDE database server. 12 | -------------------------------------------------------------------------------- 13 | module Lambda.Client.Connection where 14 | 15 | -------------------------------------------------------------------------------- 16 | import Lambda.Bus 17 | import Lambda.Prelude 18 | import Lambda.Prelude.Stopwatch 19 | import Protocol.Package 20 | 21 | -------------------------------------------------------------------------------- 22 | import Lambda.Client.EndPoint 23 | import Lambda.Client.Messages 24 | import qualified Lambda.Client.Operation as Operation 25 | import Lambda.Client.Settings 26 | import Lambda.Client.TcpConnection 27 | 28 | -------------------------------------------------------------------------------- 29 | -- | Holds connection attempt state. 30 | data Attempt = 31 | Attempt { attemptCount :: !Int 32 | -- ^ How many times we tried to connect to the server. 33 | , attemptLastTime :: !NominalDiffTime 34 | -- ^ Since when we try to connect to the database server. 35 | } 36 | 37 | -------------------------------------------------------------------------------- 38 | -- | Creates a new 'Attempt'. 39 | freshAttempt :: Internal -> React Settings Attempt 40 | freshAttempt Internal{..} = Attempt 1 <$> stopwatchElapsed _stopwatch 41 | 42 | -------------------------------------------------------------------------------- 43 | -- | Connection attempt state. 44 | data ConnectingState 45 | = Reconnecting 46 | | ConnectionEstablishing TcpConnection 47 | 48 | -------------------------------------------------------------------------------- 49 | -- | Manager state. 50 | data Stage 51 | = Init 52 | | Connecting Attempt ConnectingState 53 | | Connected TcpConnection 54 | | Closed 55 | 56 | -------------------------------------------------------------------------------- 57 | -- | Performs an action if at 'Init' stage. 58 | whenInit :: Internal -> React Settings () -> React Settings () 59 | whenInit Internal{..} m = 60 | readIORef _stageRef >>= \case 61 | Init -> m 62 | _ -> pure () 63 | 64 | -------------------------------------------------------------------------------- 65 | -- | Performs an action if at 'Connecting' stage and 'Reconnecting' state. 66 | whenReconnecting :: Internal 67 | -> (Attempt -> React Settings ()) 68 | -> React Settings () 69 | whenReconnecting Internal{..} k = 70 | readIORef _stageRef >>= \case 71 | Connecting att Reconnecting -> k att 72 | _ -> pure () 73 | 74 | -------------------------------------------------------------------------------- 75 | -- | Performs an action if at 'Connecting' stage and 'ConnectionEstablishing' 76 | -- state. 77 | whenConnectionEstablishing :: Internal 78 | -> (Attempt -> TcpConnection -> React Settings ()) 79 | -> React Settings () 80 | whenConnectionEstablishing Internal{..} k = 81 | readIORef _stageRef >>= \case 82 | Connecting att (ConnectionEstablishing conn) -> k att conn 83 | _ -> pure () 84 | 85 | -------------------------------------------------------------------------------- 86 | -- | Performs an action if at 'Connected' stage or 'Connecting' stage and 87 | -- 'ConnectionEstablishing' state. 88 | whenConnectionAvalaible :: Internal 89 | -> (TcpConnection -> React Settings ()) 90 | -> React Settings () 91 | whenConnectionAvalaible Internal{..} k = 92 | readIORef _stageRef >>= \case 93 | Connecting _ (ConnectionEstablishing conn) -> k conn 94 | Connected conn -> k conn 95 | _ -> pure () 96 | 97 | -------------------------------------------------------------------------------- 98 | -- | Switches to `Reconnecting` state. 99 | switchToReconnecting :: Internal -> Int -> React Settings () 100 | switchToReconnecting Internal{..} tries = do 101 | elapsed <- stopwatchElapsed _stopwatch 102 | let att = Attempt tries elapsed 103 | atomicWriteIORef _stageRef (Connecting att Reconnecting) 104 | 105 | -------------------------------------------------------------------------------- 106 | -- | Switches to 'ConnectionEstablishing' state. 107 | switchToConnectionEstablishing :: Internal 108 | -> Attempt 109 | -> TcpConnection 110 | -> React Settings () 111 | switchToConnectionEstablishing Internal{..} att conn = do 112 | atomicWriteIORef _stageRef (Connecting att (ConnectionEstablishing conn)) 113 | 114 | -------------------------------------------------------------------------------- 115 | -- | Switches to 'Connected' stage. 116 | switchToConnected :: Internal -> TcpConnection -> React Settings () 117 | switchToConnected Internal{..} conn = 118 | atomicWriteIORef _stageRef (Connected conn) 119 | 120 | -------------------------------------------------------------------------------- 121 | -- | Switches to 'Closed' stage. 122 | switchToClosed :: Internal -> React Settings () 123 | switchToClosed Internal{..} = atomicWriteIORef _stageRef Closed 124 | 125 | -------------------------------------------------------------------------------- 126 | -- | Connection manager state. 127 | data Internal = 128 | Internal { _builder :: ConnectionBuilder 129 | -- ^ Connection build. It knows how to create a new connection to 130 | -- the server. 131 | , _stageRef :: IORef Stage 132 | -- ^ Stage reference. 133 | , _ops :: Operation.Manager 134 | , _stopwatch :: Stopwatch 135 | } 136 | 137 | -------------------------------------------------------------------------------- 138 | -- | Tick message sends by a timer. Its goal is to keep the manager stimulated 139 | -- so it can detects connection or operation timeouts. 140 | data Tick = Tick 141 | 142 | -------------------------------------------------------------------------------- 143 | -- | Connection manager application. 144 | app :: ConnectionBuilder -> Configure Settings () 145 | app builder = do 146 | ref <- newIORef Init 147 | let connRef = ConnectionRef $ 148 | do stage <- readIORef ref 149 | case stage of 150 | Connecting _ (ConnectionEstablishing conn) -> pure (Just conn) 151 | Connected conn -> pure (Just conn) 152 | _ -> pure Nothing 153 | 154 | self <- Internal builder ref <$> Operation.new connRef 155 | <*> newStopwatch 156 | 157 | timer Tick 0.2 Undefinitely 158 | 159 | subscribe (onEstablished self) 160 | subscribe (onConnectionError self) 161 | subscribe (onPackageArrived self) 162 | subscribe (onTick self) 163 | subscribe (onNewRequest self) 164 | 165 | appStart $ startConnecting self 166 | 167 | -------------------------------------------------------------------------------- 168 | -- | Called when a connection has been established. 169 | onEstablished :: Internal -> ConnectionEstablished -> React Settings () 170 | onEstablished self (ConnectionEstablished conn) = established self conn 171 | 172 | -------------------------------------------------------------------------------- 173 | -- | Called when the current connection has closed. 174 | onConnectionError :: Internal -> ConnectionClosed -> React Settings () 175 | onConnectionError self (ConnectionClosed target cause) = 176 | whenConnectionAvalaible self $ \conn -> 177 | when (conn == target) $ 178 | closeTcpConnection self cause conn 179 | 180 | -------------------------------------------------------------------------------- 181 | -- | Called when a 'Pkg' arrived. 182 | onPackageArrived :: Internal -> PkgArrived -> React Settings () 183 | onPackageArrived self (PkgArrived sender pkg) = packageArrived self sender pkg 184 | 185 | -------------------------------------------------------------------------------- 186 | -- | Called when timer message 'Tick' arrived. Depending of the manager it does 187 | -- the following. 188 | -- 189 | -- * 'Connecting': Verify if the connection attempt has timeout. If yes, it 190 | -- tries a new connection attempt. 191 | -- 192 | -- * 'Connected': We let the operation manager performing its internal 193 | -- bookkeeping. 194 | onTick :: Internal -> Tick -> React Settings () 195 | onTick self@Internal{..} _ = readIORef _stageRef >>= \case 196 | Connecting att state 197 | | onGoingConnection state -> 198 | do elapsed <- stopwatchElapsed _stopwatch 199 | timeout <- connectionTimeout <$> reactSettings 200 | 201 | unless (elapsed - attemptLastTime att < timeout) $ 202 | do let retries = attemptCount att + 1 203 | switchToReconnecting self retries 204 | logDebug [i|Checking reconnection... (attempt #{retries}).|] 205 | connecting self 206 | | otherwise -> pure () 207 | 208 | Connected{} -> Operation.tick _ops 209 | 210 | _ -> pure () 211 | where 212 | onGoingConnection Reconnecting = True 213 | onGoingConnection ConnectionEstablishing{} = True 214 | 215 | -------------------------------------------------------------------------------- 216 | -- | First action done when the application is up. 217 | startConnecting :: Internal -> React Settings () 218 | startConnecting self = whenInit self $ do 219 | switchToReconnecting self 1 220 | connecting self 221 | 222 | -------------------------------------------------------------------------------- 223 | -- | Tries to open a 'TcpConnection'. 224 | connecting :: Internal -> React Settings () 225 | connecting self@Internal{..} = whenReconnecting self $ \att -> do 226 | setts <- reactSettings 227 | let endpoint = 228 | case connectionType setts of 229 | Static host port -> EndPoint host port 230 | 231 | conn <- connect _builder endpoint 232 | switchToConnectionEstablishing self att conn 233 | 234 | -------------------------------------------------------------------------------- 235 | -- | If the 'TcpConnection' is valid, switches to 'Connected' stage. 236 | established :: Internal -> TcpConnection -> React Settings () 237 | established self@Internal{..} conn = 238 | whenConnectionEstablishing self $ \_ expected -> 239 | when (conn == expected) $ 240 | do logDebug [i|TCP connection established #{conn}.|] 241 | switchToConnected self conn 242 | 243 | -------------------------------------------------------------------------------- 244 | -- | If 'TcpConnection' which sent that 'Pkg' is the same as the one we store 245 | -- at 'Connected' stage, we propagate the 'Pkg' to the operation manager. 246 | packageArrived :: Internal -> TcpConnection -> Pkg -> React Settings () 247 | packageArrived self sender pkg = 248 | whenConnectionAvalaible self $ \known -> 249 | when (known == sender) $ 250 | case pkgCmd pkg of 251 | 0x01 -> 252 | let newPkg = pkg { pkgCmd = 0x02 } 253 | in enqueuePkg sender newPkg 254 | _ -> Operation.arrived (_ops self) pkg 255 | 256 | -------------------------------------------------------------------------------- 257 | -- | Closes a 'TcpConnection', creates or updates an 'Attempt' if the connection 258 | -- manager stage is not 'Closed'. 259 | closeTcpConnection :: Internal 260 | -> SomeException 261 | -> TcpConnection 262 | -> React Settings () 263 | closeTcpConnection self@Internal{..} cause conn = do 264 | logDebug [i|closeTcpConnection: connection #{conn}. Cause: #{cause}.|] 265 | dispose conn 266 | logDebug [i|closeTcpConnection: connection #{conn} disposed.|] 267 | 268 | readIORef _stageRef >>= \case 269 | Closed -> pure () 270 | stage -> 271 | do att <- 272 | case stage of 273 | Connecting old _ -> pure old 274 | _ -> freshAttempt self 275 | 276 | atomicWriteIORef _stageRef (Connecting att Reconnecting) 277 | 278 | -------------------------------------------------------------------------------- 279 | -- | Registers a new request. It will be sent promptly to the database server. 280 | onNewRequest :: Internal -> NewRequest -> React Settings () 281 | onNewRequest Internal{..} request = Operation.submit _ops request 282 | 283 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/EndPoint.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client.EndPoint 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Client.EndPoint where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Lambda.Prelude 16 | 17 | -------------------------------------------------------------------------------- 18 | -- | Gathers both an IPv4 and a port. 19 | data EndPoint = 20 | EndPoint 21 | { endPointIp :: !String 22 | , endPointPort :: !Int 23 | } deriving Eq 24 | 25 | -------------------------------------------------------------------------------- 26 | instance Show EndPoint where 27 | show (EndPoint h p) = h <> ":" <> show p 28 | 29 | -------------------------------------------------------------------------------- 30 | emptyEndPoint :: EndPoint 31 | emptyEndPoint = EndPoint "" 0 32 | 33 | -------------------------------------------------------------------------------- 34 | data NodeEndPoints = 35 | NodeEndPoints 36 | { tcpEndPoint :: !EndPoint 37 | , secureEndPoint :: !(Maybe EndPoint) 38 | } deriving Show 39 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/Messages.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client.Messages 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Lambda.Client.Messages where 12 | 13 | -------------------------------------------------------------------------------- 14 | import Lambda.Prelude 15 | import Protocol.Operation 16 | 17 | -------------------------------------------------------------------------------- 18 | -- | New request coming from the user. 19 | data NewRequest where 20 | NewRequest :: Request a -> (Either String a -> IO ()) -> NewRequest 21 | 22 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/Operation.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client.Operation 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -- Operation manager. It prepares requests from the user and handle responses 11 | -- from the database server. It also manages operations timeout. 12 | -------------------------------------------------------------------------------- 13 | module Lambda.Client.Operation where 14 | 15 | -------------------------------------------------------------------------------- 16 | import Numeric.Natural 17 | 18 | -------------------------------------------------------------------------------- 19 | import Lambda.Bus 20 | import Lambda.Prelude 21 | import Lambda.Prelude.Stopwatch 22 | import Protocol.Message 23 | import Protocol.Operation 24 | import Protocol.Package 25 | 26 | -------------------------------------------------------------------------------- 27 | import Lambda.Client.Messages 28 | import Lambda.Client.Settings 29 | import Lambda.Client.TcpConnection 30 | 31 | -------------------------------------------------------------------------------- 32 | -- | Meta-information related to operation transaction. 33 | data Meta = 34 | Meta { attempts :: !Natural 35 | -- ^ Number of time this operation has been tried. 36 | , correlation :: !PkgId 37 | -- ^ Id of the transaction. 38 | , started :: !NominalDiffTime 39 | -- ^ Since when this operation has been emitted. 40 | } 41 | 42 | -------------------------------------------------------------------------------- 43 | -- | Creates a new 'Meta'. 44 | newMeta :: Stopwatch -> React Settings Meta 45 | newMeta s = Meta 0 <$> freshPkgId 46 | <*> stopwatchElapsed s 47 | 48 | -------------------------------------------------------------------------------- 49 | -- | Represents an ongoing transaction. 50 | data Pending where 51 | Pending :: Meta 52 | -> Request a 53 | -> (Either String a -> IO ()) -- The callback to execute once we get a response. 54 | -> Pending 55 | 56 | -------------------------------------------------------------------------------- 57 | -- | Represents a request put on hold because at the moment it was submitted, 58 | -- an open 'TcpConnection' wasn't available. Those requests will be retried 59 | -- once the connection manager calls 'tick'. 60 | data Awaiting where 61 | Awaiting :: Request a 62 | -> (Either String a -> IO ()) 63 | -> Awaiting 64 | 65 | -------------------------------------------------------------------------------- 66 | -- | Operation manager reference. 67 | data Manager = 68 | Manager { connRef :: ConnectionRef 69 | -- ^ Allows us to know if a 'TcpConnection' is available. 70 | , pendings :: IORef (HashMap PkgId Pending) 71 | , awaitings :: IORef (Seq Awaiting) 72 | , stopwatch :: Stopwatch 73 | } 74 | 75 | -------------------------------------------------------------------------------- 76 | -- | Creates an operation manager instance. 77 | new :: ConnectionRef -> Configure Settings Manager 78 | new ref = 79 | Manager ref <$> newIORef mempty 80 | <*> newIORef mempty 81 | <*> newStopwatch 82 | 83 | -------------------------------------------------------------------------------- 84 | -- | Submits a new operation request. 85 | submit :: Manager -> NewRequest -> React Settings () 86 | submit Manager{..} (NewRequest req callback) = 87 | maybeConnection connRef >>= \case 88 | Just conn -> 89 | do meta <- newMeta stopwatch 90 | let op = Operation (correlation meta) req 91 | pending = Pending meta req callback 92 | pkg = createPkg op 93 | 94 | modifyIORef' pendings (insertMap (correlation meta) pending) 95 | enqueuePkg conn pkg 96 | 97 | Nothing -> 98 | let awaiting = Awaiting req callback 99 | in modifyIORef' awaitings (`snoc` awaiting) 100 | 101 | -------------------------------------------------------------------------------- 102 | -- | Updates operation manager state by submitting a incoming 'Pkg'. 103 | arrived :: Manager -> Pkg -> React Settings () 104 | arrived Manager{..} pkg@Pkg{..} = do 105 | reg <- readIORef pendings 106 | case lookup pkgId reg of 107 | Nothing -> logWarn [i|Unknown request #{pkgId} response. Discarded.|] 108 | Just (Pending _ req callback) -> 109 | do case parseResp pkg req of 110 | Nothing -> 111 | do logError [i|Unexpected request response on #{pkgId}. Discarded|] 112 | liftIO $ callback (Left "Unexpected request") 113 | Just resp -> liftIO $ callback (Right $ responseType resp) 114 | 115 | writeIORef pendings (deleteMap pkgId reg) 116 | 117 | -------------------------------------------------------------------------------- 118 | -- | Performs operation manager internal bookkeepping like keeping track of 119 | -- timeout operations or retrying awaited requests. 120 | -- TODO - Implement pending request checking so we can detect which operation 121 | -- has timeout. 122 | tick :: Manager -> React Settings () 123 | tick self@Manager{..} = do 124 | logDebug "Enter tick..." 125 | as <- atomicModifyIORef' awaitings $ \cur -> (mempty, cur) 126 | traverse_ submitting as 127 | logDebug "Leave tick." 128 | where 129 | submitting (Awaiting req callback) = 130 | submit self (NewRequest req callback) 131 | 132 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/Settings.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Client.Settings 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Client.Settings where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Lambda.Prelude 16 | 17 | -------------------------------------------------------------------------------- 18 | -- | Client settings. 19 | data Settings = 20 | Settings 21 | { connectionType :: !ConnectionType 22 | -- ^ Connection type. 23 | , connectionTimeout :: !NominalDiffTime 24 | -- ^ How long a connection much take before being considered as timeout. 25 | } 26 | 27 | -------------------------------------------------------------------------------- 28 | -- * 'connectionType' = 'Static' /"localhost"/ /1113/. 29 | -- * 'connectionTimeout' = /3/ seconds. 30 | defaultSettings :: Settings 31 | defaultSettings = 32 | Settings { connectionType = Static "localhost" 1113 33 | , connectionTimeout = 3 -- secs. 34 | } 35 | 36 | -------------------------------------------------------------------------------- 37 | -- | Types of connection supported. 38 | data ConnectionType = Static String Int 39 | 40 | -------------------------------------------------------------------------------- 41 | -------------------------------------------------------------------------------- /lambda-client/library/Lambda/Client/TcpConnection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Lambda.Client.TcpConnection 6 | -- Copyright : (C) 2017 Yorick Laupa 7 | -- License : (see the file LICENSE) 8 | -- Maintainer: Yorick Laupa 9 | -- Stability : experimental 10 | -- Portability: non-portable 11 | -- 12 | -- TCP connection type declarations. 13 | -------------------------------------------------------------------------------- 14 | module Lambda.Client.TcpConnection 15 | ( ConnectionBuilder(..) 16 | , TcpConnection(..) 17 | , RecvOutcome(..) 18 | , PkgArrived(..) 19 | , ConnectionError(..) 20 | , ConnectionEstablished(..) 21 | , ConnectionClosed(..) 22 | , ConnectionRef(..) 23 | , getConnection 24 | , connectionBuilder 25 | , connectionError 26 | ) where 27 | 28 | -------------------------------------------------------------------------------- 29 | import Data.Serialize 30 | import Lambda.Bus 31 | import Lambda.Logger 32 | import Lambda.Prelude 33 | import Protocol.Package 34 | import qualified Network.Connection as Network 35 | 36 | -------------------------------------------------------------------------------- 37 | import Lambda.Client.EndPoint 38 | import Lambda.Client.Settings 39 | 40 | -------------------------------------------------------------------------------- 41 | -- | Utility type that knows how to create a 'TcpConnection'. 42 | newtype ConnectionBuilder = 43 | ConnectionBuilder { connect :: EndPoint -> React Settings TcpConnection } 44 | 45 | -------------------------------------------------------------------------------- 46 | -- | Represents all kind of outcome that can occur when we try to read from a 47 | -- TCP socket. 48 | data RecvOutcome 49 | = ResetByPeer 50 | | Recv Pkg 51 | | WrongFraming 52 | | ParsingError 53 | 54 | --------------------------------------------------------------------------------- 55 | type ConnectionId = UUID 56 | 57 | -------------------------------------------------------------------------------- 58 | -- | Stateful computation that knows when a 'TcpConnection' is available. 59 | newtype ConnectionRef = 60 | ConnectionRef { maybeConnection :: React Settings (Maybe TcpConnection) } 61 | 62 | -------------------------------------------------------------------------------- 63 | -- | Partial way to obtain a 'TcpConnection'. Use it when you really sure a 64 | -- 'TcpConnection' is available at that time. 65 | getConnection :: ConnectionRef -> React Settings TcpConnection 66 | getConnection ref = 67 | maybeConnection ref >>= \case 68 | Just conn -> return conn 69 | Nothing -> do 70 | logError "Expected a connection but got none." 71 | throwString "No current connection (impossible situation)" 72 | 73 | -------------------------------------------------------------------------------- 74 | -- | Represents a tcp connection. 75 | data TcpConnection = 76 | TcpConnection { connectionId :: ConnectionId 77 | -- ^ Unique connection id. 78 | , connectionEndPoint :: EndPoint 79 | -- ^ Endpoint supported by this connection. 80 | , enqueuePkg :: Pkg -> React Settings () 81 | -- ^ Pushes a 'Pkg' to be sent. 82 | , dispose :: React Settings () 83 | -- ^ Called when a conection is disposed. 84 | } 85 | 86 | -------------------------------------------------------------------------------- 87 | instance Show TcpConnection where 88 | show TcpConnection{..} = 89 | [i|"Connection #{connectionId} on show #{connectionEndPoint}.|] 90 | 91 | -------------------------------------------------------------------------------- 92 | instance Eq TcpConnection where 93 | a == b = connectionId a == connectionId b 94 | 95 | -------------------------------------------------------------------------------- 96 | -- | 'TcpConnection' internal state. So far, only closeable queue. 97 | newtype ConnectionState = 98 | ConnectionState { _sendQueue :: TBMQueue Pkg } 99 | 100 | -------------------------------------------------------------------------------- 101 | -- | Event sent when 'Pkg' has been sent by the server. 102 | data PkgArrived = PkgArrived TcpConnection Pkg deriving Typeable 103 | 104 | -------------------------------------------------------------------------------- 105 | -- | Event sent when a 'TcpConnection' has errored. 106 | data ConnectionError = 107 | ConnectionError TcpConnection SomeException deriving Typeable 108 | 109 | -------------------------------------------------------------------------------- 110 | -- | Smart constructor from 'ConnectionError' event. 111 | connectionError :: Exception e => TcpConnection -> e -> ConnectionError 112 | connectionError c = ConnectionError c . toException 113 | 114 | -------------------------------------------------------------------------------- 115 | -- | Event sent when a connection has been closed. 116 | data ConnectionClosed = ConnectionClosed TcpConnection SomeException 117 | deriving Typeable 118 | 119 | -------------------------------------------------------------------------------- 120 | -- | Event sent when a 'TcpConnection' has been established. 121 | data ConnectionEstablished = ConnectionEstablished TcpConnection 122 | 123 | -------------------------------------------------------------------------------- 124 | -- | Event sent when a connection has been stopped abruptly. 125 | newtype ConnectionResetByPeer = ConnectionResetByPeer SomeException 126 | 127 | -------------------------------------------------------------------------------- 128 | instance Show ConnectionResetByPeer where 129 | show (ConnectionResetByPeer reason) = 130 | "Connection reset by peer: " <> show reason 131 | 132 | -------------------------------------------------------------------------------- 133 | instance Exception ConnectionResetByPeer 134 | 135 | -------------------------------------------------------------------------------- 136 | -- | Error raised when the communication protocol expectation hasn't been meet. 137 | data ProtocolError 138 | = WrongFramingError !String 139 | -- ^ See https://blog.stephencleary.com/2009/04/message-framing.html 140 | -- for more information. 141 | | PkgParsingError !String 142 | -- Wrong 'Pkg' format. 143 | deriving Typeable 144 | 145 | -------------------------------------------------------------------------------- 146 | instance Show ProtocolError where 147 | show (WrongFramingError reason) = "Pkg framing error: " <> reason 148 | show (PkgParsingError reason) = "Pkg parsing error: " <> reason 149 | 150 | -------------------------------------------------------------------------------- 151 | instance Exception ProtocolError 152 | 153 | -------------------------------------------------------------------------------- 154 | -- | Creates asynchronous TCP connection. 155 | connectionBuilder :: Lambda Settings ConnectionBuilder 156 | connectionBuilder = do 157 | ctx <- liftIO $ Network.initConnectionContext 158 | return $ ConnectionBuilder $ \ept -> do 159 | cid <- freshUUID 160 | state <- createState 161 | 162 | mfix $ \self -> do 163 | tcpConnAsync <- async $ 164 | tryAny (openConnection ctx ept) >>= \case 165 | Left e -> do 166 | publish (ConnectionClosed self e) 167 | throw e 168 | Right conn -> do 169 | publish (ConnectionEstablished self) 170 | return conn 171 | 172 | sendAsync <- async (sending state self tcpConnAsync) 173 | recvAsync <- async (receiving state self tcpConnAsync) 174 | return TcpConnection { connectionId = cid 175 | , connectionEndPoint = ept 176 | , enqueuePkg = enqueue state 177 | , dispose = do 178 | closeState state 179 | disposeConnection tcpConnAsync 180 | cancel sendAsync 181 | cancel recvAsync 182 | } 183 | 184 | -------------------------------------------------------------------------------- 185 | -- | Creates a 'TcpConnection' internal state. 186 | createState :: React Settings ConnectionState 187 | createState = ConnectionState <$> liftIO (newTBMQueueIO 500) 188 | 189 | -------------------------------------------------------------------------------- 190 | -- | Closes a 'TcpConnection'. 191 | closeState :: ConnectionState -> React Settings () 192 | closeState ConnectionState{..} = atomically $ closeTBMQueue _sendQueue 193 | 194 | -------------------------------------------------------------------------------- 195 | -- | Opens a TCP connection. 196 | openConnection :: Network.ConnectionContext 197 | -> EndPoint 198 | -> React Settings Network.Connection 199 | openConnection ctx ept = liftIO $ Network.connectTo ctx params 200 | where 201 | host = endPointIp ept 202 | port = fromIntegral $ endPointPort ept 203 | params = Network.ConnectionParams host port Nothing Nothing 204 | 205 | -------------------------------------------------------------------------------- 206 | -- | Closes and disposes a tcp connection. 207 | disposeConnection :: Async Network.Connection -> React Settings () 208 | disposeConnection as = traverse_ tryDisposing =<< pollAsync as 209 | where 210 | tryDisposing = traverse_ disposing 211 | disposing = liftIO . Network.connectionClose 212 | 213 | -------------------------------------------------------------------------------- 214 | -- | Parses a 'Pkg' from a TCP connection. 215 | receivePkg :: TcpConnection -> Network.Connection -> React Settings Pkg 216 | receivePkg self conn = 217 | tryAny (liftIO $ Network.connectionGetExact conn 4) >>= \case 218 | Left e -> do 219 | publish (ConnectionClosed self e) 220 | throw e 221 | Right frame -> 222 | case runGet get frame of 223 | Left reason -> do 224 | let cause = WrongFramingError reason 225 | publish (connectionError self cause) 226 | throw cause 227 | Right prefix -> do 228 | let frameSiz = pkgPrefixIntegral prefix 229 | tryAny (liftIO $ Network.connectionGetExact conn frameSiz) >>= \case 230 | Left e -> do 231 | publish (ConnectionClosed self e) 232 | throw e 233 | Right payload -> 234 | case runGet get payload of 235 | Left reason -> do 236 | let cause = PkgParsingError reason 237 | publish (connectionError self cause) 238 | throw cause 239 | Right pkg -> return pkg 240 | 241 | -------------------------------------------------------------------------------- 242 | -- | Read thread worker. 243 | receiving :: ConnectionState 244 | -> TcpConnection 245 | -> Async Network.Connection 246 | -> React Settings () 247 | receiving ConnectionState{..} self tcpConnAsync = 248 | forever . go =<< waitAsync tcpConnAsync 249 | where 250 | go conn = 251 | publish . PkgArrived self =<< receivePkg self conn 252 | 253 | -------------------------------------------------------------------------------- 254 | -- | Adds a 'Pkg' to the connection queue. 255 | enqueue :: ConnectionState -> Pkg -> React Settings () 256 | enqueue ConnectionState{..} pkg@Pkg{..} = do 257 | logDebug [i|Pkg enqueued: #{pkg}|] 258 | atomically $ writeTBMQueue _sendQueue pkg 259 | 260 | -------------------------------------------------------------------------------- 261 | -- | Write thread worker. 262 | sending :: ConnectionState 263 | -> TcpConnection 264 | -> Async Network.Connection 265 | -> React Settings () 266 | sending ConnectionState{..} self tcpConnAsync = go =<< waitAsync tcpConnAsync 267 | where 268 | go conn = 269 | let loop = traverse_ send =<< atomically (readTBMQueue _sendQueue) 270 | send pkg = 271 | tryAny (liftIO $ Network.connectionPut conn bytes) >>= \case 272 | Left e -> publish (ConnectionClosed self e) 273 | Right _ -> do 274 | -- TODO - Re-introduce monitoring metrics. 275 | -- monitorAddDataTransmitted (length bytes) 276 | loop 277 | where 278 | bytes = runPut $ put pkg in 279 | loop 280 | 281 | -------------------------------------------------------------------------------- /lambda-client/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | benchmarks: 5 | lambda-client-benchmarks: 6 | dependencies: 7 | - base 8 | - lambda-client 9 | - criterion 10 | ghc-options: 11 | - -rtsopts 12 | - -threaded 13 | - -with-rtsopts=-N 14 | main: Main.hs 15 | source-dirs: benchmark 16 | category: Other 17 | description: lambda-client is a new Haskeleton package. 18 | dependencies: 19 | - classy-prelude 20 | executables: 21 | lambda-client: 22 | dependencies: 23 | - base 24 | - lambda-client 25 | ghc-options: 26 | - -rtsopts 27 | - -threaded 28 | - -with-rtsopts=-N 29 | main: Main.hs 30 | source-dirs: executable 31 | extra-source-files: 32 | - CHANGELOG.md 33 | - LICENSE.md 34 | - package.yaml 35 | - README.md 36 | ghc-options: -Wall 37 | github: YoEight/lambda-client 38 | library: 39 | default-extensions: 40 | - NoImplicitPrelude 41 | - GADTs 42 | - TypeFamilies 43 | - OverloadedStrings 44 | - QuasiQuotes 45 | - MultiParamTypeClasses 46 | - GeneralizedNewtypeDeriving 47 | - RecordWildCards 48 | - LambdaCase 49 | dependencies: 50 | - base 51 | - lambda-protocol 52 | - lambda-prelude 53 | - lambda-bus 54 | - lambda-logger 55 | - connection 56 | - cereal 57 | source-dirs: library 58 | license: MIT 59 | maintainer: Yorick Laupa 60 | name: lambda-client 61 | synopsis: A new Haskeleton package. 62 | tests: 63 | lambda-client-test-suite: 64 | default-extensions: 65 | - NoImplicitPrelude 66 | - OverloadedStrings 67 | 68 | dependencies: 69 | - base 70 | - lambda-client 71 | - tasty 72 | - tasty-hspec 73 | - aeson 74 | - async 75 | - classy-prelude 76 | ghc-options: 77 | - -rtsopts 78 | - -threaded 79 | - -with-rtsopts=-N 80 | main: Main.hs 81 | source-dirs: test-suite 82 | version: '0.0.0' 83 | -------------------------------------------------------------------------------- /lambda-client/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Main where 12 | 13 | -------------------------------------------------------------------------------- 14 | import Control.Concurrent.Async 15 | import Data.List.NonEmpty 16 | import Data.Aeson 17 | import qualified Test.Tasty 18 | -- Hspec is one of the providers for Tasty. It provides a nice syntax for 19 | -- writing tests. Its website has more info: . 20 | import Test.Tasty.Hspec 21 | 22 | import Lambda.Client 23 | import ClassyPrelude hiding (fromList) 24 | 25 | main :: IO () 26 | main = do 27 | -- test <- testSpec "lambda-client" spec 28 | -- Test.Tasty.defaultMain test 29 | client <- newClientWithDefault 30 | eid <- freshId 31 | let payload = object [ "IsHaskellTheBest" .= True ] 32 | evt = Event { eventType = "lde-mockup" 33 | , eventId = eid 34 | , eventPayload = Data $ toStrict $ encode $ payload 35 | , eventMetadata = Nothing 36 | } 37 | 38 | wres <- writeEvents client "test-stream" (fromList [evt]) AnyVersion >>= wait 39 | print wres 40 | 41 | rres <- readEvents client "test-stream" (startFrom 1) >>= wait 42 | traverse_ print $ events rres 43 | 44 | awaitShutdown client 45 | 46 | return () 47 | 48 | spec :: Spec 49 | spec = parallel $ do 50 | it "is trivially true" $ do 51 | True `shouldBe` True 52 | -------------------------------------------------------------------------------- /lambda-logger/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-logger/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | lambda-logger uses [Semantic Versioning][]. 4 | The change log is available through the [releases on GitHub][]. 5 | 6 | [Semantic Versioning]: http://semver.org/spec/v2.0.0.html 7 | [releases on GitHub]: https://github.com/YoEight/lambda-logger/releases 8 | -------------------------------------------------------------------------------- /lambda-logger/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-logger/README.md: -------------------------------------------------------------------------------- 1 | # lambda-logger 2 | 3 | LDE logging infrastructure. 4 | -------------------------------------------------------------------------------- /lambda-logger/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-logger/library/Lambda/Logger.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Logger 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Logger 13 | ( LoggerFilter(..) 14 | , LoggerRef(..) 15 | , LogType(..) 16 | , loggerCallback 17 | , toLogPredicate 18 | , newLoggerRef 19 | -- * Re-exports 20 | , module Control.Monad.Logger 21 | , module Control.Monad.Logger.CallStack 22 | , module Data.String.Interpolate.IsString 23 | ) where 24 | 25 | -------------------------------------------------------------------------------- 26 | import Control.Monad 27 | import Data.Semigroup ((<>)) 28 | 29 | -------------------------------------------------------------------------------- 30 | import Control.Monad.Logger hiding (logDebug, logInfo, logWarn, logError, logOther, logWarnSH, logOtherSH, logDebugSH, logInfoSH, logErrorSH) 31 | import Control.Monad.Logger.CallStack 32 | import Data.String.Interpolate.IsString 33 | import System.Log.FastLogger 34 | 35 | -------------------------------------------------------------------------------- 36 | data LoggerFilter 37 | = LoggerFilter (LogSource -> LogLevel -> Bool) 38 | | LoggerLevel LogLevel 39 | 40 | -------------------------------------------------------------------------------- 41 | toLogPredicate :: LoggerFilter -> (LogSource -> LogLevel -> Bool) 42 | toLogPredicate (LoggerFilter k) = k 43 | toLogPredicate (LoggerLevel lvl) = \_ t -> t >= lvl 44 | 45 | -------------------------------------------------------------------------------- 46 | data LoggerRef 47 | = LoggerRef !TimedFastLogger !LoggerFilter !Bool !(IO ()) 48 | | NoLogger 49 | 50 | -------------------------------------------------------------------------------- 51 | loggerCallback :: LoggerRef -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) 52 | loggerCallback NoLogger = \_ _ _ _ -> return () 53 | loggerCallback (LoggerRef logger filt detailed _) = \loc src lvl msg -> 54 | when (predicate src lvl) $ 55 | loggerFormat logger (if detailed then loc else defaultLoc) src lvl msg 56 | where 57 | predicate = toLogPredicate filt 58 | 59 | -------------------------------------------------------------------------------- 60 | loggerFormat :: TimedFastLogger 61 | -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) 62 | loggerFormat logger = \loc src lvl msg -> 63 | logger $ \t -> 64 | toLogStr ("["`mappend` t `mappend`"]") `mappend` lambdaLogStr loc src lvl msg 65 | 66 | -------------------------------------------------------------------------------- 67 | lambdaLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> LogStr 68 | lambdaLogStr loc _ lvl msg = 69 | [i|[#{lvlTxt}]:#{loc_module loc}:#{line}:#{col}: |] 70 | <> msg 71 | <> "\n" 72 | where 73 | lvlTxt = 74 | case lvl of 75 | LevelDebug -> "DEBUG" 76 | LevelInfo -> "INFO" 77 | LevelWarn -> "WARN" 78 | LevelError -> "ERROR" 79 | LevelOther o -> o 80 | 81 | (line, col) = loc_start loc 82 | 83 | 84 | -------------------------------------------------------------------------------- 85 | newLoggerRef :: LogType -> LoggerFilter -> Bool -> IO LoggerRef 86 | newLoggerRef LogNone _ _ = return NoLogger 87 | newLoggerRef typ filt detailed = 88 | case typ of 89 | LogNone -> return NoLogger 90 | other -> do 91 | cache <- newTimeCache simpleTimeFormat 92 | (logger, cleanup) <- newTimedFastLogger cache other 93 | return $ LoggerRef logger filt detailed cleanup 94 | -------------------------------------------------------------------------------- /lambda-logger/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | category: Other 5 | description: LDE logging infrastructure. 6 | 7 | default-extensions: 8 | - OverloadedStrings 9 | - QuasiQuotes 10 | 11 | extra-source-files: 12 | - CHANGELOG.md 13 | - LICENSE.md 14 | - package.yaml 15 | - README.md 16 | - stack.yaml 17 | ghc-options: -Wall 18 | library: 19 | dependencies: 20 | - base 21 | - monad-logger 22 | - fast-logger 23 | - interpolate 24 | source-dirs: library 25 | license: MIT 26 | maintainer: Yorick Laupa 27 | name: lambda-logger 28 | synopsis: A new Haskeleton package. 29 | version: '0.0.0' 30 | -------------------------------------------------------------------------------- /lambda-logger/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: nightly-2017-08-12 19 | compiler: ghc-8.2.1 20 | 21 | # User packages to be built. 22 | # Various formats can be used as shown in the example below. 23 | # 24 | # packages: 25 | # - some-directory 26 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 27 | # - location: 28 | # git: https://github.com/commercialhaskell/stack.git 29 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # extra-dep: true 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | # 36 | # A package marked 'extra-dep: true' will only be built if demanded by a 37 | # non-dependency (i.e. a user package), and its test suites and benchmarks 38 | # will not be run. This is useful for tweaking upstream packages. 39 | packages: 40 | - '.' 41 | # Dependency packages to be pulled from upstream that are not in the resolver 42 | # (e.g., acme-missiles-0.3) 43 | extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | flags: {} 47 | 48 | # Extra package databases containing global packages 49 | extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.4" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /lambda-node/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-node/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | lambda-node uses [Semantic Versioning][]. 4 | The change log is available through the [releases on GitHub][]. 5 | 6 | [Semantic Versioning]: http://semver.org/spec/v2.0.0.html 7 | [releases on GitHub]: https://github.com/YoEight/lambda-node/releases 8 | -------------------------------------------------------------------------------- /lambda-node/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-node/README.md: -------------------------------------------------------------------------------- 1 | # lambda-node 2 | 3 | Single database node 4 | 5 | ## Build 6 | 7 | ``` 8 | $ stack build 9 | ``` -------------------------------------------------------------------------------- /lambda-node/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-node/benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | -- You can benchmark your code quickly and effectively with Criterion. See its 2 | -- website for help: . 3 | import Criterion.Main 4 | 5 | main :: IO () 6 | main = defaultMain [bench "const" (whnf const ())] 7 | -------------------------------------------------------------------------------- /lambda-node/executable/Main.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Main where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Lambda.Node 16 | import Lambda.Prelude 17 | 18 | -------------------------------------------------------------------------------- 19 | main :: IO () 20 | main = Lambda.Node.nodeMain 21 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Node (nodeMain) where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Lambda.Bus 16 | import qualified Lambda.Node.Manager.Connection as Connection 17 | import Lambda.Prelude 18 | 19 | -------------------------------------------------------------------------------- 20 | nodeMain :: IO () 21 | nodeMain = lambdaMain $ do 22 | mainBus <- newBus 23 | Connection.new mainBus 24 | busProcessedEverything mainBus 25 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Index.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node.Index 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Lambda.Node.Index 12 | ( Indexer 13 | , newIndexer 14 | , indexEvents 15 | , readStreamEvents 16 | , nextStreamEventNum 17 | ) where 18 | 19 | -------------------------------------------------------------------------------- 20 | import Lambda.Prelude 21 | import Protocol.Types 22 | 23 | -------------------------------------------------------------------------------- 24 | import qualified Lambda.Node.Journal as Journal 25 | import Lambda.Node.Settings 26 | 27 | -------------------------------------------------------------------------------- 28 | data IndexKey 29 | = StreamKey StreamName 30 | | StreamNumKey StreamName 31 | deriving (Eq, Ord, Show, Generic) 32 | 33 | -------------------------------------------------------------------------------- 34 | instance Hashable IndexKey 35 | 36 | -------------------------------------------------------------------------------- 37 | type SeekPos = Integer 38 | 39 | -------------------------------------------------------------------------------- 40 | data IndexValue 41 | = StreamEvents (Seq SeekPos) 42 | | StreamNextNum EventNumber 43 | 44 | -------------------------------------------------------------------------------- 45 | type IndexMap = HashMap IndexKey IndexValue 46 | 47 | -------------------------------------------------------------------------------- 48 | insertStreamEventPos :: StreamName -> Seq SeekPos -> IndexMap -> IndexMap 49 | insertStreamEventPos name pos = alterMap go (StreamKey name) 50 | where 51 | go Nothing = Just (StreamEvents pos) 52 | go (Just val) = 53 | let StreamEvents old = val 54 | in Just $ StreamEvents (old <> pos) 55 | 56 | -------------------------------------------------------------------------------- 57 | lookupStreamEventPos :: StreamName -> IndexMap -> Maybe [SeekPos] 58 | lookupStreamEventPos name = fmap go . lookup (StreamKey name) 59 | where 60 | go val = 61 | let StreamEvents pos = val 62 | in toList pos 63 | 64 | -------------------------------------------------------------------------------- 65 | insertStreamNextNum :: StreamName -> EventNumber -> IndexMap -> IndexMap 66 | insertStreamNextNum name num = insertMap (StreamNumKey name) (StreamNextNum num) 67 | 68 | -------------------------------------------------------------------------------- 69 | lookupStreamNextNum :: StreamName -> IndexMap -> Maybe EventNumber 70 | lookupStreamNextNum name = fmap go . lookup (StreamNumKey name) 71 | where 72 | go val = 73 | let StreamNextNum num = val 74 | in num 75 | 76 | -------------------------------------------------------------------------------- 77 | data Indexer = 78 | Indexer { _map :: IORef IndexMap 79 | , _journal :: Journal.InMemory 80 | } 81 | 82 | -------------------------------------------------------------------------------- 83 | newIndexer :: Lambda Settings Indexer 84 | newIndexer = Indexer <$> newIORef mempty 85 | <*> Journal.newInMemory 86 | 87 | -------------------------------------------------------------------------------- 88 | indexEvents :: Indexer 89 | -> StreamName 90 | -> [Event] 91 | -> Lambda Settings EventNumber 92 | indexEvents self name xs = do 93 | mnum <- lookupStreamNextNum name <$> readIORef (_map self) 94 | 95 | let num = fromMaybe 0 mnum 96 | next = num + len 97 | 98 | poss <- Journal.runInMemory (_journal self) (foldM persist mempty $ indexed num) 99 | 100 | atomicModifyIORef (_map self) $ \m -> 101 | let m' = insertStreamNextNum name next $ 102 | insertStreamEventPos name poss m 103 | in (m', next) 104 | where 105 | len = fromIntegral $ length xs 106 | 107 | indexed from = zip [from..] xs 108 | 109 | persist acc (num, evt) = 110 | fmap (acc `snoc`) (Journal.marshal (SavedEvent num evt)) 111 | 112 | -------------------------------------------------------------------------------- 113 | nextStreamEventNum :: Indexer -> StreamName -> Lambda Settings EventNumber 114 | nextStreamEventNum self name = do 115 | mnum <- lookupStreamNextNum name <$> readIORef (_map self) 116 | return $ fromMaybe 0 mnum 117 | 118 | -------------------------------------------------------------------------------- 119 | readStreamEvents :: Indexer 120 | -> StreamName 121 | -> Lambda Settings (Maybe [SavedEvent]) 122 | readStreamEvents self name = do 123 | m <- readIORef (_map self) 124 | 125 | let mpos = lookupStreamEventPos name m 126 | action = traverse (fmap toList . traverse readStream) mpos 127 | 128 | Journal.runInMemory (_journal self) action 129 | where 130 | readStream pos = do 131 | Journal.setPos pos 132 | Journal.unmarshal 133 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Journal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Lambda.Node.Journal 5 | -- Copyright : (C) 2017 Yorick Laupa 6 | -- License : (see the file LICENSE) 7 | -- Maintainer: Yorick Laupa 8 | -- Stability : experimental 9 | -- Portability: non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Node.Journal 13 | ( Journal 14 | , InMemory 15 | , newInMemory 16 | , runInMemory 17 | , setPos 18 | , getPos 19 | , marshal 20 | , unmarshal 21 | ) where 22 | 23 | -------------------------------------------------------------------------------- 24 | import qualified Control.Monad.Operational as Operational 25 | import Data.Serialize 26 | import Lambda.Prelude 27 | 28 | -------------------------------------------------------------------------------- 29 | import Lambda.Node.Settings 30 | 31 | -------------------------------------------------------------------------------- 32 | type Journal o = Operational.Program Op o 33 | 34 | -------------------------------------------------------------------------------- 35 | data Op a where 36 | SetPos :: Integer -> Op () 37 | GetPos :: Op Integer 38 | Marshal :: Serialize a => a -> Op Integer 39 | Unmarshal :: Serialize a => Op a 40 | 41 | -------------------------------------------------------------------------------- 42 | setPos :: Integer -> Journal () 43 | setPos pos = Operational.singleton (SetPos pos) 44 | 45 | -------------------------------------------------------------------------------- 46 | getPos :: Journal Integer 47 | getPos = Operational.singleton GetPos 48 | 49 | -------------------------------------------------------------------------------- 50 | marshal :: Serialize a => a -> Journal Integer 51 | marshal a = Operational.singleton (Marshal a) 52 | 53 | -------------------------------------------------------------------------------- 54 | unmarshal :: Serialize a => Journal a 55 | unmarshal = Operational.singleton Unmarshal 56 | 57 | -------------------------------------------------------------------------------- 58 | data InMemory = 59 | InMemory { _memCurPos :: IORef Integer 60 | , _memEOF :: IORef Integer 61 | , _memLogs :: IORef (HashMap Integer ByteString) 62 | } 63 | 64 | -------------------------------------------------------------------------------- 65 | newInMemory :: Lambda Settings InMemory 66 | newInMemory = 67 | InMemory <$> newIORef 0 68 | <*> newIORef 0 69 | <*> newIORef mempty 70 | 71 | -------------------------------------------------------------------------------- 72 | runInMemory :: forall m a. MonadBase IO m 73 | => InMemory 74 | -> Journal a 75 | -> m a 76 | runInMemory self sm = Operational.interpretWithMonad go sm 77 | where 78 | go :: forall i. Op i -> m i 79 | go (SetPos pos) = 80 | writeIORef (_memCurPos self) pos 81 | 82 | go GetPos = 83 | readIORef (_memCurPos self) 84 | 85 | go (Marshal a) = do 86 | eof <- readIORef (_memEOF self) 87 | 88 | let bytes = encode a 89 | nextPos = eof + (fromIntegral $ length bytes) 90 | 91 | modifyIORef' (_memLogs self) (insertMap eof bytes) 92 | writeIORef (_memCurPos self) nextPos 93 | writeIORef (_memEOF self) nextPos 94 | pure eof 95 | 96 | go Unmarshal = do 97 | pos <- readIORef (_memCurPos self) 98 | m <- readIORef (_memLogs self) 99 | case lookup pos m of 100 | Nothing -> liftBase $ fail "End of journal reached" 101 | Just bytes -> 102 | case decode bytes of 103 | Right a -> pure a 104 | _ -> liftBase $ fail "Failed to unmarshal" 105 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Manager/Connection.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node.Manager.Connection 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Node.Manager.Connection (new) where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Network.Simple.TCP 16 | 17 | -------------------------------------------------------------------------------- 18 | import Data.Serialize 19 | import Lambda.Bus 20 | import Lambda.Logger 21 | import Lambda.Prelude 22 | import Lambda.Prelude.Stopwatch 23 | import Network.Connection 24 | import Protocol.Package 25 | import Protocol.Message 26 | import Protocol.Operation 27 | 28 | -------------------------------------------------------------------------------- 29 | import qualified Lambda.Node.Manager.Operation as Operation 30 | import Lambda.Node.Settings 31 | 32 | -------------------------------------------------------------------------------- 33 | data CheckState 34 | = CheckInterval 35 | | CheckTimeout 36 | 37 | -------------------------------------------------------------------------------- 38 | data HealthTracking = 39 | HealthTracking 40 | { _healthLastPkgNum :: !Integer 41 | , _healthLastCheck :: !NominalDiffTime 42 | , _healthCheckState :: !CheckState 43 | } 44 | 45 | -------------------------------------------------------------------------------- 46 | initHealthTracking :: HealthTracking 47 | initHealthTracking = HealthTracking 0 0 CheckInterval 48 | 49 | -------------------------------------------------------------------------------- 50 | manageHeartbeat :: ClientSocket -> React Settings () 51 | manageHeartbeat self@ClientSocket{..} = do 52 | setts <- reactSettings 53 | pkgNum <- readIORef _clientPkgNum 54 | track <- readIORef _clientHealth 55 | elapsed <- stopwatchElapsed _clientStopwatch 56 | 57 | let duration = 58 | case _healthCheckState track of 59 | CheckInterval -> heartbeatInterval setts 60 | CheckTimeout -> heartbeatTimeout setts 61 | 62 | if pkgNum > _healthLastPkgNum track 63 | then writeIORef _clientHealth (HealthTracking pkgNum elapsed CheckInterval) 64 | else 65 | when (elapsed - _healthLastCheck track >= duration) $ 66 | case _healthCheckState track of 67 | CheckInterval -> do 68 | pkg <- liftIO heartbeatRequest 69 | enqueuePkg self pkg 70 | let newTrack = HealthTracking pkgNum elapsed CheckTimeout 71 | atomicWriteIORef _clientHealth newTrack 72 | CheckTimeout -> do 73 | clientId <- reactSelfId 74 | logWarn [i|Connection #{clientId} closed: Heartbeat timeout.|] 75 | closeConnection self "HEARTBEAT TIMEOUT" 76 | 77 | -------------------------------------------------------------------------------- 78 | data ClientSocket = 79 | ClientSocket 80 | { _clientOpMgr :: !Operation.Manager 81 | , _clientConn :: !Connection 82 | , _clientAddr :: !SockAddr 83 | , _clientStopwatch :: !Stopwatch 84 | , _clientQueue :: !(TBMQueue Pkg) 85 | , _clientPkgNum :: !(IORef Integer) 86 | , _clientHealth :: !(IORef HealthTracking) 87 | , _clientClosing :: !(IORef Bool) 88 | } 89 | 90 | -------------------------------------------------------------------------------- 91 | -- Events 92 | -------------------------------------------------------------------------------- 93 | newtype PackageArrived = PackageArrived Pkg 94 | 95 | -------------------------------------------------------------------------------- 96 | data Tick = Tick 97 | 98 | -------------------------------------------------------------------------------- 99 | data ConnectionClosed = ConnectionClosed String 100 | 101 | -------------------------------------------------------------------------------- 102 | app :: Bus Settings -> Configure Settings () 103 | app mainBus = appStart (startListening mainBus) 104 | 105 | -------------------------------------------------------------------------------- 106 | startListening :: Bus Settings -> React Settings () 107 | startListening mainBus = do 108 | opMgr <- Operation.new 109 | servingFork mainBus opMgr . connectionSettings =<< reactSettings 110 | 111 | -------------------------------------------------------------------------------- 112 | new :: Bus Settings -> Lambda Settings () 113 | new mainBus = do 114 | configure mainBus (app mainBus) 115 | 116 | -------------------------------------------------------------------------------- 117 | clientApp :: ClientSocket -> Configure Settings () 118 | clientApp self = do 119 | subscribe (onPackageArrived self) 120 | subscribe (onConnectionClosed self) 121 | subscribe (onOperationResp self) 122 | subscribe (onTick self) 123 | 124 | timer Tick 0.2 Undefinitely 125 | 126 | appStart $ 127 | do clientId <- reactSelfId 128 | _ <- async (processingIncomingPackage self) 129 | _ <- async (processingOutgoingPackage self) 130 | logInfo [i|New connection #{clientId} on #{_clientAddr self}|] 131 | 132 | -------------------------------------------------------------------------------- 133 | newClientSocket :: Operation.Manager 134 | -> Connection 135 | -> SockAddr 136 | -> Configure s ClientSocket 137 | newClientSocket mgr conn addr = 138 | ClientSocket mgr conn addr 139 | <$> newStopwatch 140 | <*> (liftIO $ newTBMQueueIO 500) 141 | <*> newIORef 0 142 | <*> newIORef initHealthTracking 143 | <*> newIORef False 144 | 145 | -------------------------------------------------------------------------------- 146 | servingFork :: Bus Settings 147 | -> Operation.Manager 148 | -> ConnectionSettings 149 | -> React Settings () 150 | servingFork mainBus opMgr ConnectionSettings{..} = void $ fork $ liftBaseWith $ \run -> do 151 | ctx <- initConnectionContext 152 | 153 | serve (Host hostname) (show portNumber) $ \(sock, addr) -> run $ reactLambda $ 154 | do conn <- liftIO $ connectFromSocket ctx sock connectionParams 155 | child <- busNewChild mainBus 156 | configure child (clientConf conn addr) 157 | busProcessedEverything child 158 | where 159 | clientConf sock addr = 160 | newClientSocket opMgr sock addr >>= clientApp 161 | 162 | connectionParams = 163 | ConnectionParams hostname portNumber Nothing Nothing 164 | 165 | -------------------------------------------------------------------------------- 166 | processingIncomingPackage :: ClientSocket -> React Settings () 167 | processingIncomingPackage ClientSocket{..} = 168 | handleAny onError $ forever $ do 169 | prefixBytes <- liftIO $ connectionGetExact _clientConn 4 170 | case decode prefixBytes of 171 | Left _ -> throwString [i|Wrong package framing.|] 172 | Right (PkgPrefix len) -> do 173 | payload <- liftIO $ connectionGetExact _clientConn (fromIntegral len) 174 | case decode payload of 175 | Left e -> throwString [i|Package parsing error #{e}.|] 176 | Right pkg -> publish (PackageArrived pkg) 177 | 178 | -------------------------------------------------------------------------------- 179 | processingOutgoingPackage :: ClientSocket -> React Settings () 180 | processingOutgoingPackage ClientSocket{..} = handleAny onError loop 181 | where 182 | loop = do 183 | msg <- atomically $ readTBMQueue _clientQueue 184 | for_ msg $ \pkg -> 185 | do liftIO $ connectionPut _clientConn (encode pkg) 186 | loop 187 | 188 | -------------------------------------------------------------------------------- 189 | enqueuePkg :: ClientSocket -> Pkg -> React Settings () 190 | enqueuePkg ClientSocket{..} pkg = atomically $ writeTBMQueue _clientQueue pkg 191 | 192 | -------------------------------------------------------------------------------- 193 | incrPkgNum :: ClientSocket -> React Settings () 194 | incrPkgNum ClientSocket{..} = atomicModifyIORef' _clientPkgNum $ 195 | \n -> (succ n, ()) 196 | 197 | -------------------------------------------------------------------------------- 198 | closeConnection :: ClientSocket -> String -> React Settings () 199 | closeConnection ClientSocket{..} reason = do 200 | done <- atomicModifyIORef' _clientClosing $ \b -> (True, b) 201 | clientId <- reactSelfId 202 | unless done $ do 203 | atomically $ closeTBMQueue _clientQueue 204 | logInfo [i|Connection #{clientId} closed, reason: #{reason}.|] 205 | stop 206 | 207 | -------------------------------------------------------------------------------- 208 | -- Event Handlers 209 | -------------------------------------------------------------------------------- 210 | onTick :: ClientSocket -> Tick -> React Settings () 211 | onTick self _ = manageHeartbeat self 212 | 213 | -------------------------------------------------------------------------------- 214 | onPackageArrived :: ClientSocket -> PackageArrived -> React Settings () 215 | onPackageArrived self@ClientSocket{..} (PackageArrived pkg@Pkg{..}) = do 216 | incrPkgNum self 217 | logDebug [i|Package #{pkgId} arrived.|] 218 | 219 | case pkgCmd of 220 | 0x01 -> enqueuePkg self (heartbeatResponse pkgId) 221 | 0x02 -> return () 222 | _ -> 223 | case parseOp pkg of 224 | Nothing -> logError [i|Wrong operation format on #{pkg}.|] 225 | Just (SomeOperation op) -> do 226 | logDebug "Received new operation." 227 | handleOperation self op 228 | 229 | -------------------------------------------------------------------------------- 230 | onOperationResp :: ClientSocket -> Operation.Resp -> React Settings () 231 | onOperationResp self (Operation.Resp op resp) = 232 | let pkg = createRespPkg op resp 233 | in enqueuePkg self pkg 234 | 235 | -------------------------------------------------------------------------------- 236 | handleOperation :: ClientSocket -> Operation a -> React Settings () 237 | handleOperation self op = Operation.push (_clientOpMgr self) op 238 | 239 | -------------------------------------------------------------------------------- 240 | onError :: SomeException -> React s () 241 | onError e = publish (ConnectionClosed $ show e) 242 | 243 | -------------------------------------------------------------------------------- 244 | onConnectionClosed :: ClientSocket -> ConnectionClosed -> React Settings () 245 | onConnectionClosed self (ConnectionClosed reason) = 246 | closeConnection self reason 247 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Manager/Operation.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node.Manager.Operation 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Lambda.Node.Manager.Operation 12 | ( Manager 13 | , Resp(..) 14 | , new 15 | , push 16 | ) where 17 | 18 | -------------------------------------------------------------------------------- 19 | import Lambda.Bus 20 | import Lambda.Prelude 21 | import Protocol.Operation 22 | import Protocol.Types 23 | 24 | -------------------------------------------------------------------------------- 25 | import qualified Lambda.Node.Index as Index 26 | import Lambda.Node.Settings 27 | 28 | -------------------------------------------------------------------------------- 29 | data Req where 30 | Req :: SomeBus Settings -> Operation a -> Req 31 | 32 | -------------------------------------------------------------------------------- 33 | data Resp where 34 | Resp :: Operation a -> a -> Resp 35 | 36 | -------------------------------------------------------------------------------- 37 | data Manager = Manager { _bus :: Bus Settings 38 | , _index :: Index.Indexer 39 | } 40 | 41 | -------------------------------------------------------------------------------- 42 | new :: React Settings Manager 43 | new = reactLambda $ do 44 | bus <- newBus 45 | ind <- Index.newIndexer 46 | 47 | let self = Manager bus ind 48 | 49 | configure bus $ 50 | do subscribe (onReq self) 51 | 52 | pure self 53 | 54 | -------------------------------------------------------------------------------- 55 | onReq :: Manager -> Req -> React Settings () 56 | onReq self (Req sender op@(Operation _ req)) = 57 | case req of 58 | WriteEvents name _ evts -> do 59 | num <- reactLambda $ Index.indexEvents (_index self) name (toList evts) 60 | 61 | let resp = WriteEventsResp num WriteSuccess 62 | 63 | sendTo sender (Resp op resp) 64 | ReadEvents name _ -> do 65 | res <- reactLambda $ Index.readStreamEvents (_index self) name 66 | 67 | let evts = foldMap toList res 68 | resp = ReadEventsResp name evts ReadSuccess (-1) True 69 | 70 | sendTo sender (Resp op resp) 71 | 72 | -------------------------------------------------------------------------------- 73 | push :: Manager -> Operation a -> React Settings () 74 | push self op = do 75 | sender <- reactBus 76 | sendTo (_bus self) (Req sender op) 77 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Monitoring.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node.Monitoring 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Node.Monitoring 13 | ( Monitoring 14 | , createMonitoring 15 | , counterIncr 16 | , counterAdd 17 | , gaugeIncr 18 | , gaugeDecr 19 | , gaugeAdd 20 | , gaugeSubtract 21 | , gaugeSet 22 | , labelSet 23 | , labelModify 24 | , distributionAdd 25 | , distributionAddN 26 | ) where 27 | 28 | -------------------------------------------------------------------------------- 29 | import Lambda.Prelude 30 | import qualified System.Metrics as Metrics 31 | import qualified System.Metrics.Distribution as Distribution 32 | import qualified System.Metrics.Counter as Counter 33 | import qualified System.Metrics.Gauge as Gauge 34 | import qualified System.Metrics.Label as Label 35 | import qualified System.Remote.Monitoring as Monitoring 36 | 37 | -------------------------------------------------------------------------------- 38 | type Counts = HashMap Text Counter.Counter 39 | type Gauges = HashMap Text Gauge.Gauge 40 | type Labels = HashMap Text Label.Label 41 | type Distributions = HashMap Text Distribution.Distribution 42 | 43 | -------------------------------------------------------------------------------- 44 | data Monitoring = 45 | Monitoring { _server :: Monitoring.Server 46 | , _counts :: MVar Counts 47 | , _gauges :: MVar Gauges 48 | , _labels :: MVar Labels 49 | , _dists :: MVar Distributions 50 | } 51 | 52 | -------------------------------------------------------------------------------- 53 | _store :: Monitoring -> Metrics.Store 54 | _store = Monitoring.serverMetricStore . _server 55 | 56 | -------------------------------------------------------------------------------- 57 | createMonitoring :: MonadBase IO m => m Monitoring 58 | createMonitoring = 59 | Monitoring <$> liftBase (Monitoring.forkServer "0.0.0.0" 9000) 60 | <*> newMVar mempty 61 | <*> newMVar mempty 62 | <*> newMVar mempty 63 | <*> newMVar mempty 64 | 65 | -------------------------------------------------------------------------------- 66 | lookupVarDefault :: MonadBaseControl IO m 67 | => MVar (HashMap Text a) 68 | -> Text 69 | -> m a 70 | -> m a 71 | lookupVarDefault var name def = 72 | modifyMVar var $ \m -> 73 | case lookup name m of 74 | Nothing -> do 75 | a <- def 76 | return (insertMap name a m, a) 77 | Just a -> return (m, a) 78 | 79 | -------------------------------------------------------------------------------- 80 | withMetric :: MonadBaseControl IO m 81 | => Monitoring 82 | -> (Monitoring -> MVar (HashMap Text a)) 83 | -> (Metrics.Store -> IO a) 84 | -> Text 85 | -> m a 86 | withMetric m getVar getDef name = 87 | liftBase $ lookupVarDefault (getVar m) name (getDef $ _store m) 88 | 89 | -------------------------------------------------------------------------------- 90 | counterIncr :: MonadBaseControl IO m => Monitoring -> Text -> m () 91 | counterIncr m name = liftBase . Counter.inc =<< getCounter m name 92 | 93 | -------------------------------------------------------------------------------- 94 | getCounter :: MonadBaseControl IO m 95 | => Monitoring 96 | -> Text 97 | -> m Counter.Counter 98 | getCounter m name = 99 | withMetric m _counts (Metrics.createCounter name) name 100 | 101 | -------------------------------------------------------------------------------- 102 | getGauge :: MonadBaseControl IO m 103 | => Monitoring 104 | -> Text 105 | -> m Gauge.Gauge 106 | getGauge m name = 107 | withMetric m _gauges (Metrics.createGauge name) name 108 | 109 | -------------------------------------------------------------------------------- 110 | getLabel :: MonadBaseControl IO m 111 | => Monitoring 112 | -> Text 113 | -> m Label.Label 114 | getLabel m name = 115 | withMetric m _labels (Metrics.createLabel name) name 116 | 117 | -------------------------------------------------------------------------------- 118 | getDistribution :: MonadBaseControl IO m 119 | => Monitoring 120 | -> Text 121 | -> m Distribution.Distribution 122 | getDistribution m name = 123 | withMetric m _dists (Metrics.createDistribution name) name 124 | 125 | -------------------------------------------------------------------------------- 126 | counterAdd :: MonadBaseControl IO m => Monitoring -> Text -> Int64 -> m () 127 | counterAdd m name value = do 128 | c <- getCounter m name 129 | liftBase $ Counter.add c value 130 | 131 | -------------------------------------------------------------------------------- 132 | gaugeIncr :: MonadBaseControl IO m => Monitoring -> Text -> m () 133 | gaugeIncr m name = liftBase . Gauge.inc =<< getGauge m name 134 | 135 | -------------------------------------------------------------------------------- 136 | gaugeDecr :: MonadBaseControl IO m => Monitoring -> Text -> m () 137 | gaugeDecr m name = liftBase . Gauge.dec =<< getGauge m name 138 | 139 | -------------------------------------------------------------------------------- 140 | gaugeAdd :: MonadBaseControl IO m => Monitoring -> Text -> Int64 -> m () 141 | gaugeAdd m name value = do 142 | g <- getGauge m name 143 | liftBase $ Gauge.add g value 144 | 145 | -------------------------------------------------------------------------------- 146 | gaugeSubtract :: MonadBaseControl IO m => Monitoring -> Text -> Int64 -> m () 147 | gaugeSubtract m name value = do 148 | g <- getGauge m name 149 | liftBase $ Gauge.subtract g value 150 | 151 | -------------------------------------------------------------------------------- 152 | gaugeSet :: MonadBaseControl IO m => Monitoring -> Text -> Int64 -> m () 153 | gaugeSet m name value = do 154 | g <- getGauge m name 155 | liftBase $ Gauge.set g value 156 | 157 | -------------------------------------------------------------------------------- 158 | labelSet :: MonadBaseControl IO m => Monitoring -> Text -> Text -> m () 159 | labelSet m name value = do 160 | l <- getLabel m name 161 | liftBase $ Label.set l value 162 | 163 | -------------------------------------------------------------------------------- 164 | labelModify :: MonadBaseControl IO m 165 | => Monitoring 166 | -> (Text -> Text) 167 | -> Text 168 | -> m () 169 | labelModify m f name = do 170 | l <- getLabel m name 171 | liftBase $ Label.modify f l 172 | 173 | -------------------------------------------------------------------------------- 174 | distributionAdd :: MonadBaseControl IO m => Monitoring -> Text -> Double -> m () 175 | distributionAdd m name value = do 176 | d <- getDistribution m name 177 | liftBase $ Distribution.add d value 178 | 179 | -------------------------------------------------------------------------------- 180 | distributionAddN :: MonadBaseControl IO m 181 | => Monitoring 182 | -> Text 183 | -> Double 184 | -> Int64 185 | -> m () 186 | distributionAddN m name value times = do 187 | d <- getDistribution m name 188 | liftBase $ Distribution.addN d value times 189 | 190 | 191 | -------------------------------------------------------------------------------- /lambda-node/library/Lambda/Node/Settings.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Node.Settings 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Node.Settings where 13 | 14 | -------------------------------------------------------------------------------- 15 | import Lambda.Logger 16 | import Lambda.Prelude 17 | import Options.Applicative 18 | import Network 19 | import Text.PrettyPrint hiding ((<>)) 20 | 21 | -------------------------------------------------------------------------------- 22 | data Settings = 23 | Settings 24 | { heartbeatInterval :: !NominalDiffTime 25 | , heartbeatTimeout :: !NominalDiffTime 26 | , connectionSettings :: !ConnectionSettings 27 | } 28 | 29 | -------------------------------------------------------------------------------- 30 | instance PrettyPrint Settings where 31 | pprint Settings{..} = 32 | vcat [ text "heartbeat-interval: " <+> text (show heartbeatInterval) 33 | , text "heartbeat-timeout:" <+> text (show heartbeatTimeout) 34 | , text "Connection settings:" 35 | , nest 5 (ppConnectionSettings connectionSettings) 36 | ] 37 | 38 | -------------------------------------------------------------------------------- 39 | instance AppSettings Settings where 40 | settingsParser = parseSettings 41 | 42 | description _ = 43 | fullDesc <> header "LDE - Lambda Database Experiment." 44 | <> progDesc "Starts the LDE server." 45 | 46 | -------------------------------------------------------------------------------- 47 | parseSettings :: Parser Settings 48 | parseSettings = Settings <$> parseHeartbeatInterval 49 | <*> parseHeartbeatTimeout 50 | <*> parseConnectionSettings 51 | 52 | -------------------------------------------------------------------------------- 53 | parseHeartbeatInterval :: Parser NominalDiffTime 54 | parseHeartbeatInterval = option (maybeReader check) go 55 | where 56 | go = long "heartbeat-interval" <> metavar "HEARTBEAT_INTERVAL" 57 | <> help "Heartbeat interval: Delay in which \ 58 | \the server start to worry if it \ 59 | \has no news from the client." 60 | <> value 0.5 61 | <> showDefault 62 | check input = 63 | fmap realToFrac (readMay input :: Maybe Double) 64 | 65 | -------------------------------------------------------------------------------- 66 | parseHeartbeatTimeout :: Parser NominalDiffTime 67 | parseHeartbeatTimeout = option (maybeReader check) go 68 | where 69 | go = long "heartbeat-timeout" <> metavar "HEARTBEAT_TIMEOUT" 70 | <> help "Heartbeat timeout: Delay that a \ 71 | \client has to send a heartbeat \ 72 | \response." 73 | <> value 0.75 74 | <> showDefault 75 | check input = 76 | fmap realToFrac (readMay input :: Maybe Double) 77 | 78 | -------------------------------------------------------------------------------- 79 | data ConnectionSettings = 80 | ConnectionSettings 81 | { portNumber :: !PortNumber 82 | , hostname :: !String 83 | } 84 | 85 | -------------------------------------------------------------------------------- 86 | ppConnectionSettings :: ConnectionSettings -> Doc 87 | ppConnectionSettings ConnectionSettings{..} = 88 | vcat [ text "host:" <+> text hostname 89 | , text "port:" <+> text (show portNumber) 90 | ] 91 | 92 | -------------------------------------------------------------------------------- 93 | parseConnectionSettings :: Parser ConnectionSettings 94 | parseConnectionSettings = 95 | ConnectionSettings <$> parsePort 96 | <*> parseHost 97 | 98 | -------------------------------------------------------------------------------- 99 | parseHost :: Parser String 100 | parseHost = strOption go 101 | where 102 | go = long "host" <> metavar "HOST" 103 | <> help "Server hostname address." 104 | <> value "127.0.0.1" 105 | <> showDefault 106 | 107 | -------------------------------------------------------------------------------- 108 | parsePort :: Parser PortNumber 109 | parsePort = option (eitherReader check) go 110 | where 111 | go = long "port" <> metavar "PORT" 112 | <> help "Server port." 113 | <> value 1113 114 | <> showDefault 115 | 116 | check input = 117 | case readMay input of 118 | Nothing -> Left "Invalid port number." 119 | Just port 120 | | port > 0 && port < 65535 -> Right port 121 | | otherwise -> Left [i|Port should be ]0-65535[|] 122 | -------------------------------------------------------------------------------- /lambda-node/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | benchmarks: 5 | lambda-node-benchmarks: 6 | dependencies: 7 | - base 8 | - lambda-node 9 | - criterion 10 | ghc-options: 11 | - -rtsopts 12 | - -threaded 13 | - -with-rtsopts=-N 14 | main: Main.hs 15 | source-dirs: benchmark 16 | category: Other 17 | description: lambda-node is a new Haskeleton package. 18 | executables: 19 | lambda-node: 20 | dependencies: 21 | - base 22 | - lambda-node 23 | ghc-options: 24 | - -rtsopts 25 | - -threaded 26 | - -with-rtsopts=-N 27 | main: Main.hs 28 | source-dirs: executable 29 | dependencies: 30 | - classy-prelude 31 | - optparse-applicative 32 | - monad-logger 33 | - fast-logger 34 | - ekg 35 | - ekg-core 36 | - uuid 37 | - lambda-prelude 38 | - lambda-logger 39 | - lambda-bus 40 | - connection 41 | - operational 42 | default-extensions: 43 | - NoImplicitPrelude 44 | - LambdaCase 45 | - OverloadedStrings 46 | - TypeFamilies 47 | - GADTs 48 | - GeneralizedNewtypeDeriving 49 | - MultiParamTypeClasses 50 | - FlexibleContexts 51 | - QuasiQuotes 52 | - RecordWildCards 53 | - DeriveGeneric 54 | - RankNTypes 55 | extra-source-files: 56 | - CHANGELOG.md 57 | - LICENSE.md 58 | - package.yaml 59 | - README.md 60 | - stack.yaml 61 | ghc-options: -Wall 62 | github: YoEight/lambda-node 63 | library: 64 | dependencies: 65 | - base 66 | - network 67 | - clock 68 | - network-simple 69 | - lambda-protocol 70 | - cereal 71 | - time 72 | - pretty 73 | - aeson 74 | - machines 75 | - resourcet 76 | source-dirs: library 77 | license: MIT 78 | maintainer: Yorick Laupa 79 | name: lambda-node 80 | synopsis: A new Haskeleton package. 81 | tests: 82 | lambda-node-test-suite: 83 | dependencies: 84 | - base 85 | - lambda-node 86 | - tasty 87 | - tasty-hspec 88 | ghc-options: 89 | - -rtsopts 90 | - -threaded 91 | - -with-rtsopts=-N 92 | main: Main.hs 93 | source-dirs: test-suite 94 | version: '0.0.0' 95 | -------------------------------------------------------------------------------- /lambda-node/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.22 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | - '../lambda-protocol' 41 | # Dependency packages to be pulled from upstream that are not in the resolver 42 | # (e.g., acme-missiles-0.3) 43 | extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | flags: {} 47 | 48 | # Extra package databases containing global packages 49 | extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.4" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /lambda-node/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -- Tasty makes it easy to test your code. It is a test framework that can 2 | -- combine many different types of tests into one suite. See its website for 3 | -- help: . 4 | import qualified Test.Tasty 5 | -- Hspec is one of the providers for Tasty. It provides a nice syntax for 6 | -- writing tests. Its website has more info: . 7 | import Test.Tasty.Hspec 8 | 9 | main :: IO () 10 | main = do 11 | test <- testSpec "lambda-node" spec 12 | Test.Tasty.defaultMain test 13 | 14 | spec :: Spec 15 | spec = parallel $ do 16 | it "is trivially true" $ do 17 | True `shouldBe` True -------------------------------------------------------------------------------- /lambda-prelude/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-prelude/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-prelude/README.md: -------------------------------------------------------------------------------- 1 | # [lambda-prelude][] 2 | 3 | Thanks for starting a project with Haskeleton! If you haven't heard of it 4 | before, I suggest reading the introductory blog post. You can find it here: 5 | . 6 | 7 | Before you get started, there are a few things that this template couldn't 8 | provide for you. You should: 9 | 10 | - Add a synopsis to `package.yaml`. It should be a short (one sentence) 11 | explanation of your project. 12 | 13 | - Add a description to `package.yaml`. This can be whatever you want it to 14 | be. 15 | 16 | - Add a category to `package.yaml`. A list of categories is available on 17 | Hackage at . 18 | 19 | - Rename `library/Example.hs` to whatever you want your top-level module to 20 | be called. Typically this is the same as your package name but in 21 | `CamelCase` instead of `kebab-case`. 22 | 23 | - Don't forget to rename the reference to it in 24 | `executable/Main.hs`! 25 | 26 | - If you are on an older version of Stack (<1.0.4), delete `package.yaml` and 27 | remove `/*.cabal` from your `.gitignore`. 28 | 29 | Once you've done that, start working on your project with the Stack commands 30 | you know and love. 31 | 32 | ``` sh 33 | # Build the project. 34 | stack build 35 | 36 | # Run the test suite. 37 | stack test 38 | 39 | # Run the benchmarks. 40 | stack bench 41 | 42 | # Generate documentation. 43 | stack haddock 44 | ``` 45 | 46 | Thanks again, and happy hacking! 47 | 48 | [lambda-prelude]: https://github.com/YoEight/lambda-prelude 49 | -------------------------------------------------------------------------------- /lambda-prelude/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-prelude/library/Lambda/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Lambda.Prelude 10 | -- Copyright : (C) 2017 Yorick Laupa 11 | -- License : (see the file LICENSE) 12 | -- 13 | -- Maintainer : Yorick Laupa 14 | -- Stability : provisional 15 | -- Portability : non-portable 16 | -- 17 | -------------------------------------------------------------------------------- 18 | module Lambda.Prelude 19 | ( module ClassyPrelude 20 | , module Data.String.Interpolate.IsString 21 | , module System.Clock 22 | , module Control.Monad.Fix 23 | , module Lambda.Logger 24 | -- * Lambda 25 | , Lambda(..) 26 | , getSettings 27 | , lambdaMain 28 | , lambdaMain_ 29 | -- * Settings 30 | , PrettyPrint(..) 31 | , AppSettings(..) 32 | -- * Misc 33 | , UUID 34 | , NominalDiffTime 35 | , diffUTCTime 36 | , clockTime 37 | , freshUUID 38 | , s2ns 39 | , s2mcs 40 | ) where 41 | 42 | -------------------------------------------------------------------------------- 43 | import Control.Monad.Fix 44 | import Data.Proxy 45 | 46 | -------------------------------------------------------------------------------- 47 | import ClassyPrelude 48 | import Control.Monad.Reader 49 | import Data.Time (NominalDiffTime, diffUTCTime) 50 | import Data.UUID 51 | import Data.UUID.V4 52 | import Data.String.Interpolate.IsString 53 | import Lambda.Logger 54 | import Options.Applicative 55 | import System.Clock 56 | import Text.PrettyPrint hiding ((<>)) 57 | 58 | -------------------------------------------------------------------------------- 59 | clockTime :: MonadIO m => m TimeSpec 60 | clockTime = liftIO $ getTime Monotonic 61 | 62 | -------------------------------------------------------------------------------- 63 | freshUUID :: MonadIO m => m UUID 64 | freshUUID = liftIO nextRandom 65 | 66 | -------------------------------------------------------------------------------- 67 | s2ns :: Num a => a 68 | s2ns = 10^(9 :: Int) 69 | 70 | -------------------------------------------------------------------------------- 71 | s2mcs :: Num a => a 72 | s2mcs = 10^(6 :: Int) 73 | 74 | -------------------------------------------------------------------------------- 75 | data Env app = 76 | Env { _settings :: !(LambdaSettings app) 77 | , _loggerRef :: !LoggerRef 78 | } 79 | 80 | -------------------------------------------------------------------------------- 81 | instance Functor Env where 82 | fmap f e = e { _settings = fmap f (_settings e) } 83 | 84 | -------------------------------------------------------------------------------- 85 | class PrettyPrint p where 86 | pprint :: p -> Doc 87 | 88 | -------------------------------------------------------------------------------- 89 | instance PrettyPrint () where 90 | pprint _ = mempty 91 | 92 | -------------------------------------------------------------------------------- 93 | class PrettyPrint s => AppSettings s where 94 | settingsParser :: Parser s 95 | description :: Proxy s -> InfoMod a 96 | 97 | -------------------------------------------------------------------------------- 98 | instance AppSettings () where 99 | settingsParser = pure () 100 | description _ = mempty 101 | 102 | -------------------------------------------------------------------------------- 103 | data LambdaSettings settings = 104 | LambdaSettings { loggingSettings :: !LoggingSettings 105 | , appSettings :: !settings 106 | } 107 | 108 | -------------------------------------------------------------------------------- 109 | instance Functor LambdaSettings where 110 | fmap f s = s { appSettings = f (appSettings s) } 111 | 112 | -------------------------------------------------------------------------------- 113 | instance PrettyPrint s => PrettyPrint (LambdaSettings s) where 114 | pprint LambdaSettings{..} = 115 | vcat [ "Settings:" 116 | , nest 5 $ 117 | vcat [ "Logging Settings:" 118 | , nest 5 (ppLoggingSettings loggingSettings) 119 | , "Application Settings:" 120 | , nest 5 (pprint appSettings) 121 | ] 122 | ] 123 | 124 | -------------------------------------------------------------------------------- 125 | applyProxy :: Proxy (LambdaSettings s) -> Proxy s 126 | applyProxy _ = Proxy 127 | 128 | -------------------------------------------------------------------------------- 129 | instance AppSettings s => AppSettings (LambdaSettings s) where 130 | settingsParser = parseLambdaSettings 131 | description prx = description (applyProxy prx) 132 | 133 | -------------------------------------------------------------------------------- 134 | parseLambdaSettings :: AppSettings s => Parser (LambdaSettings s) 135 | parseLambdaSettings = 136 | LambdaSettings <$> parseLoggingSettings 137 | <*> settingsParser 138 | 139 | -------------------------------------------------------------------------------- 140 | -- Main Lambda monad stack. 141 | newtype Lambda settings a = 142 | Lambda { unLambda :: ReaderT (Env settings) IO a } 143 | deriving ( Functor 144 | , Applicative 145 | , Monad 146 | , MonadFix 147 | , MonadIO 148 | , MonadThrow 149 | , MonadCatch 150 | , MonadBase IO 151 | , MonadBaseControl IO 152 | ) 153 | 154 | -------------------------------------------------------------------------------- 155 | data LoggingSettings = 156 | LoggingSettings 157 | { loggingType :: !LogType 158 | , loggingLevel :: !LoggerFilter 159 | } 160 | 161 | -------------------------------------------------------------------------------- 162 | ppLoggingSettings :: LoggingSettings -> Doc 163 | ppLoggingSettings LoggingSettings{..} = 164 | vcat [ text "logging-type:" <+> ppLogType loggingType 165 | , text "logging-level:" <+> ppLogFilter loggingLevel 166 | ] 167 | 168 | -------------------------------------------------------------------------------- 169 | ppLogType :: LogType -> Doc 170 | ppLogType LogStdout{} = text "stdout" 171 | ppLogType LogStderr{} = text "stderr" 172 | ppLogType (LogFileNoRotate path _) = text path 173 | ppLogType _ = text "*not supported*" 174 | 175 | -------------------------------------------------------------------------------- 176 | ppLogFilter :: LoggerFilter -> Doc 177 | ppLogFilter (LoggerLevel lvl) = ppLogLevel lvl 178 | ppLogFilter _ = text "*not supported*" 179 | 180 | -------------------------------------------------------------------------------- 181 | ppLogLevel :: LogLevel -> Doc 182 | ppLogLevel LevelDebug = text "debug" 183 | ppLogLevel LevelInfo = text "info" 184 | ppLogLevel LevelWarn = text "warn" 185 | ppLogLevel LevelError = text "error" 186 | ppLogLevel _ = text "*not supported*" 187 | 188 | -------------------------------------------------------------------------------- 189 | parseLoggingSettings :: Parser LoggingSettings 190 | parseLoggingSettings = 191 | LoggingSettings <$> parseLoggingType 192 | <*> parseLoggingLevel 193 | 194 | -------------------------------------------------------------------------------- 195 | parseLoggingType :: Parser LogType 196 | parseLoggingType = to <$> strOption go 197 | where 198 | go = long "logging-type" <> metavar "LOGGING_TYPE" 199 | <> help "Logging type: stdout, stderr or a file path" 200 | <> value "stdout" 201 | <> showDefault 202 | 203 | to "stdout" = LogStdout 0 204 | to "stderr" = LogStderr 0 205 | to filepath = LogFileNoRotate filepath 0 206 | -------------------------------------------------------------------------------- 207 | parseLoggingLevel :: Parser LoggerFilter 208 | parseLoggingLevel = (LoggerLevel . to) <$> strOption go 209 | where 210 | go = long "logging-level" <> metavar "LOGGING_LEVEL" 211 | <> help "Logging level: debug, info, warn and error" 212 | <> value "info" 213 | <> showDefault 214 | 215 | to :: String -> LogLevel 216 | to "debug" = LevelDebug 217 | to "info" = LevelInfo 218 | to "warn" = LevelWarn 219 | to "error" = LevelError 220 | to _ = LevelInfo 221 | 222 | -------------------------------------------------------------------------------- 223 | getSettings :: Lambda settings settings 224 | getSettings = Lambda (fmap (appSettings . _settings) ask) 225 | 226 | -------------------------------------------------------------------------------- 227 | instance MonadLogger (Lambda settings) where 228 | monadLoggerLog loc src lvl msg = Lambda $ 229 | do ref <- _loggerRef <$> ask 230 | liftIO $ loggerCallback ref loc src lvl (toLogStr msg) 231 | 232 | -------------------------------------------------------------------------------- 233 | instance MonadReader settings (Lambda settings) where 234 | ask = Lambda (fmap (appSettings . _settings) ask) 235 | local k (Lambda m) = Lambda (local (fmap k) m) 236 | 237 | -------------------------------------------------------------------------------- 238 | lambdaSettingsParser :: forall s. AppSettings s => ParserInfo (LambdaSettings s) 239 | lambdaSettingsParser = info (helper <*> settingsParser) desc 240 | where 241 | desc = description (Proxy :: Proxy (LambdaSettings s)) 242 | 243 | -------------------------------------------------------------------------------- 244 | lambdaMain :: AppSettings settings => Lambda settings a -> IO a 245 | lambdaMain (Lambda m) = 246 | do setts <- execParser lambdaSettingsParser 247 | putStrLn $ pack $ render $ pprint setts 248 | 249 | let logging = loggingSettings setts 250 | logType = loggingType logging 251 | logLevel = loggingLevel logging 252 | detailed = True 253 | 254 | env <- Env setts <$> newLoggerRef logType logLevel detailed 255 | runReaderT m env 256 | 257 | -------------------------------------------------------------------------------- 258 | lambdaMain_ :: settings -> Lambda settings a -> IO a 259 | lambdaMain_ appSetts (Lambda m) = 260 | do setts <- execParser lambdaSettingsParser 261 | let rightSetts = fmap (\() -> appSetts) setts 262 | putStrLn $ pack $ render $ pprint setts 263 | 264 | let logging = loggingSettings setts 265 | logType = loggingType logging 266 | logLevel = loggingLevel logging 267 | detailed = True 268 | 269 | env <- Env rightSetts <$> newLoggerRef logType logLevel detailed 270 | runReaderT m env 271 | -------------------------------------------------------------------------------- /lambda-prelude/library/Lambda/Prelude/Duration.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Lambda.Prelude.Duration 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- Maintainer: Yorick Laupa 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------------------- 11 | module Lambda.Prelude.Duration where 12 | 13 | -------------------------------------------------------------------------------- 14 | import Lambda.Prelude 15 | 16 | -------------------------------------------------------------------------------- 17 | newtype Duration = Duration Int64 deriving Show 18 | 19 | -------------------------------------------------------------------------------- 20 | msDuration :: Int64 -> Duration 21 | msDuration = Duration . (1000 *) 22 | 23 | -------------------------------------------------------------------------------- 24 | secsDuration :: Int64 -> Duration 25 | secsDuration = msDuration . (1000 *) 26 | -------------------------------------------------------------------------------- /lambda-prelude/library/Lambda/Prelude/Stopwatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Lambda.Prelude.Stopwatch 5 | -- Copyright : (C) 2017 Yorick Laupa 6 | -- License : (see the file LICENSE) 7 | -- Maintainer: Yorick Laupa 8 | -- Stability : experimental 9 | -- Portability: non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Lambda.Prelude.Stopwatch 13 | ( Stopwatch 14 | , newStopwatch 15 | , stopwatchElapsed 16 | ) where 17 | 18 | -------------------------------------------------------------------------------- 19 | import Lambda.Prelude 20 | 21 | -------------------------------------------------------------------------------- 22 | data Internal = 23 | Internal { _lastTime :: !UTCTime 24 | , _acc :: !NominalDiffTime 25 | } 26 | 27 | -------------------------------------------------------------------------------- 28 | initInternal :: UTCTime -> Internal 29 | initInternal now = Internal now 0 30 | 31 | -------------------------------------------------------------------------------- 32 | update :: UTCTime -> Internal -> Internal 33 | update now (Internal before acc) = Internal now acc' 34 | where 35 | acc' = acc + diffUTCTime now before 36 | 37 | -------------------------------------------------------------------------------- 38 | newtype Stopwatch = Stopwatch (MVar Internal) 39 | 40 | -------------------------------------------------------------------------------- 41 | newStopwatch :: MonadBase IO m => m Stopwatch 42 | newStopwatch = 43 | fmap Stopwatch . newMVar . initInternal =<< liftBase getCurrentTime 44 | 45 | -------------------------------------------------------------------------------- 46 | stopwatchElapsed :: MonadBaseControl IO m => Stopwatch -> m NominalDiffTime 47 | stopwatchElapsed (Stopwatch var) = 48 | modifyMVar var $ \prev -> do 49 | now <- liftBase getCurrentTime 50 | let next = update now prev 51 | return (next, _acc next) 52 | -------------------------------------------------------------------------------- /lambda-prelude/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | category: Other 5 | description: lambda-prelude is a new Haskeleton package. 6 | extra-source-files: 7 | - LICENSE.md 8 | - package.yaml 9 | - README.md 10 | - stack.yaml 11 | ghc-options: -Wall 12 | library: 13 | default-extensions: 14 | - NoImplicitPrelude 15 | - RecordWildCards 16 | dependencies: 17 | - base 18 | - classy-prelude 19 | - uuid 20 | - clock 21 | - interpolate 22 | - time 23 | - lambda-logger 24 | - mtl 25 | - pretty 26 | - optparse-applicative 27 | source-dirs: library 28 | license: MIT 29 | maintainer: Yorick Laupa 30 | name: lambda-prelude 31 | synopsis: A new Haskeleton package. 32 | tests: 33 | lambda-prelude-test-suite: 34 | dependencies: 35 | - base 36 | - lambda-prelude 37 | - tasty 38 | - tasty-hspec 39 | ghc-options: 40 | - -rtsopts 41 | - -threaded 42 | - -with-rtsopts=-N 43 | main: Main.hs 44 | source-dirs: test-suite 45 | version: '0.0.0' 46 | -------------------------------------------------------------------------------- /lambda-prelude/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: nightly-2017-08-12 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /lambda-prelude/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -- Tasty makes it easy to test your code. It is a test framework that can 2 | -- combine many different types of tests into one suite. See its website for 3 | -- help: . 4 | import qualified Test.Tasty 5 | -- Hspec is one of the providers for Tasty. It provides a nice syntax for 6 | -- writing tests. Its website has more info: . 7 | import Test.Tasty.Hspec 8 | 9 | main :: IO () 10 | main = do 11 | test <- testSpec "lambda-prelude" spec 12 | Test.Tasty.defaultMain test 13 | 14 | spec :: Spec 15 | spec = parallel $ do 16 | it "is trivially true" $ do 17 | True `shouldBe` True -------------------------------------------------------------------------------- /lambda-protocol/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /lambda-protocol/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | lambda-protocol uses [Semantic Versioning][]. 4 | The change log is available through the [releases on GitHub][]. 5 | 6 | [Semantic Versioning]: http://semver.org/spec/v2.0.0.html 7 | [releases on GitHub]: https://github.com/YoEight/lambda-protocol/releases 8 | -------------------------------------------------------------------------------- /lambda-protocol/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2017 Yorick Laupa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /lambda-protocol/README.md: -------------------------------------------------------------------------------- 1 | # lambda-protocol 2 | 3 | Provides the messages needed to communicate with the server. 4 | 5 | ### Build 6 | 7 | ```sh 8 | stack build 9 | ``` 10 | -------------------------------------------------------------------------------- /lambda-protocol/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Protocol.Message 7 | -- Copyright : (C) 2017 Yorick Laupa 8 | -- License : (see the file LICENSE) 9 | -- 10 | -- Maintainer : Yorick Laupa 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Protocol.Message 16 | ( createPkg 17 | , createRespPkg 18 | , parseOp 19 | , parseResp 20 | ) where 21 | 22 | -------------------------------------------------------------------------------- 23 | import Lambda.Prelude 24 | 25 | -------------------------------------------------------------------------------- 26 | import qualified Protocol.Message.WriteEvents as WriteEvents 27 | import qualified Protocol.Message.ReadEvents as ReadEvents 28 | import Protocol.Operation 29 | import Protocol.Package 30 | 31 | -------------------------------------------------------------------------------- 32 | createPkg :: forall a. Operation a -> Pkg 33 | createPkg Operation{..} = 34 | case operationType of 35 | WriteEvents name ver xs -> 36 | WriteEvents.createPkg operationId name ver xs 37 | ReadEvents name b -> 38 | ReadEvents.createPkg operationId name b 39 | 40 | -------------------------------------------------------------------------------- 41 | createRespPkg :: forall a. Operation a -> a -> Pkg 42 | createRespPkg Operation{..} = go operationType 43 | where 44 | go :: forall a. Request a -> a -> Pkg 45 | go WriteEvents{} (WriteEventsResp num flag) = 46 | WriteEvents.createRespPkg operationId num flag 47 | go ReadEvents{} (ReadEventsResp name xs flag num eos) = 48 | ReadEvents.createRespPkg operationId name xs flag num eos 49 | 50 | -------------------------------------------------------------------------------- 51 | parseOp :: Pkg -> Maybe SomeOperation 52 | parseOp pkg = 53 | fmap SomeOperation (WriteEvents.parseOp pkg) <|> 54 | fmap SomeOperation (ReadEvents.parseOp pkg) 55 | 56 | -------------------------------------------------------------------------------- 57 | parseResp :: forall a. Pkg -> Request a -> Maybe (Response a) 58 | parseResp pkg = go 59 | where 60 | go :: forall a. Request a -> Maybe (Response a) 61 | go WriteEvents{} = WriteEvents.parseResp pkg 62 | go ReadEvents{} = ReadEvents.parseResp pkg 63 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Message/EventRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Protocol.Message.EventRecord 7 | -- Copyright : (C) 2017 Yorick Laupa 8 | -- License : (see the file LICENSE) 9 | -- 10 | -- Maintainer : Yorick Laupa 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Protocol.Message.EventRecord where 16 | 17 | -------------------------------------------------------------------------------- 18 | import Data.ProtocolBuffers hiding (encode, decode) 19 | import Data.Serialize 20 | import Lambda.Prelude 21 | 22 | -------------------------------------------------------------------------------- 23 | import Protocol.Types 24 | 25 | -------------------------------------------------------------------------------- 26 | data EventRecordMsg = 27 | EventRecordMsg { eventMsgStreamId :: Required 1 (Value Text) 28 | , eventMsgNumber :: Required 2 (Value Int32) 29 | , eventMsgId :: Required 3 (Value ByteString) 30 | , eventMsgType :: Required 4 (Value Text) 31 | , eventMsgData :: Required 7 (Value ByteString) 32 | , eventMsgMetadata :: Optional 8 (Value ByteString) 33 | } deriving (Generic, Show) 34 | 35 | -------------------------------------------------------------------------------- 36 | instance Encode EventRecordMsg 37 | instance Decode EventRecordMsg 38 | 39 | -------------------------------------------------------------------------------- 40 | toEventRecord :: StreamName -> SavedEvent -> EventRecordMsg 41 | toEventRecord (StreamName name) (SavedEvent (EventNumber num) Event{..}) = 42 | EventRecordMsg { eventMsgStreamId = putField name 43 | , eventMsgNumber = putField num 44 | , eventMsgId = putField $ eventIdBytes eventId 45 | , eventMsgType = putField $ eventTypeText eventType 46 | , eventMsgData = putField $ dataBytes eventPayload 47 | , eventMsgMetadata = putField $ fmap encode eventMetadata 48 | } 49 | 50 | -------------------------------------------------------------------------------- 51 | fromEventRecord :: MonadPlus m => EventRecordMsg -> m SavedEvent 52 | fromEventRecord em = do 53 | eid <- 54 | case guidFromBytes $ getField $ eventMsgId em of 55 | Just guid -> return $ EventId guid 56 | _ -> mzero 57 | 58 | let dat = Data $ getField $ eventMsgData em 59 | metadat = eitherMaybe . decode =<< getField (eventMsgMetadata em) 60 | typ = EventType $ getField $ eventMsgType em 61 | 62 | return SavedEvent { eventNumber = EventNumber $ getField $ eventMsgNumber em 63 | , savedEvent = 64 | Event { eventType = typ 65 | , eventId = eid 66 | , eventPayload = dat 67 | , eventMetadata = metadat 68 | } 69 | } 70 | 71 | -------------------------------------------------------------------------------- 72 | eitherMaybe :: Either e a -> Maybe a 73 | eitherMaybe (Right a) = Just a 74 | eitherMaybe _ = Nothing 75 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Message/ReadEvents.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Protocol.Message.ReadEvents 8 | -- Copyright : (C) 2017 Yorick Laupa 9 | -- License : (see the file LICENSE) 10 | -- 11 | -- Maintainer : Yorick Laupa 12 | -- Stability : provisional 13 | -- Portability : non-portable 14 | -- 15 | -------------------------------------------------------------------------------- 16 | module Protocol.Message.ReadEvents 17 | ( createPkg 18 | , createRespPkg 19 | , parseOp 20 | , parseResp 21 | ) where 22 | 23 | -------------------------------------------------------------------------------- 24 | import Data.ProtocolBuffers hiding (encode, decode) 25 | import Data.Serialize hiding (Result) 26 | import Lambda.Prelude 27 | 28 | -------------------------------------------------------------------------------- 29 | import Protocol.Operation 30 | import Protocol.Package 31 | import Protocol.Types 32 | 33 | -------------------------------------------------------------------------------- 34 | import Protocol.Message.EventRecord 35 | 36 | -------------------------------------------------------------------------------- 37 | data ReadReq = 38 | ReadReq { readStreamId :: Required 1 (Value Text) 39 | , readStartNum :: Required 2 (Value Int32) 40 | , readBatchSize :: Required 3 (Value Int32) 41 | } deriving (Generic, Show) 42 | 43 | -------------------------------------------------------------------------------- 44 | instance Encode ReadReq 45 | instance Decode ReadReq 46 | 47 | -------------------------------------------------------------------------------- 48 | data ReadResp = 49 | ReadResp { readEvents :: Repeated 1 (Message EventRecordMsg) 50 | , readResult :: Required 2 (Enumeration ReadResultFlag) 51 | , readNextNumber :: Required 3 (Value Int32) 52 | , readEndOfStream :: Required 4 (Value Bool) 53 | , readRespStream :: Required 5 (Value Text) 54 | } deriving (Generic, Show) 55 | 56 | -------------------------------------------------------------------------------- 57 | instance Decode ReadResp 58 | instance Encode ReadResp 59 | 60 | -------------------------------------------------------------------------------- 61 | createPkg :: PkgId -> StreamName -> Batch -> Pkg 62 | createPkg pid (StreamName name) (Batch (EventNumber start) size) = 63 | Pkg { pkgCmd = 0x05 64 | , pkgId = pid 65 | , pkgPayload = runPut $ encodeMessage req 66 | } 67 | where 68 | req = ReadReq { readStreamId = putField name 69 | , readStartNum = putField start 70 | , readBatchSize = putField size 71 | } 72 | 73 | -------------------------------------------------------------------------------- 74 | createRespPkg :: PkgId 75 | -> StreamName 76 | -> [SavedEvent] 77 | -> ReadResultFlag 78 | -> EventNumber 79 | -> Bool 80 | -> Pkg 81 | createRespPkg pid name xs flag (EventNumber num) eos = 82 | Pkg { pkgCmd = 0x06 83 | , pkgId = pid 84 | , pkgPayload = runPut $ encodeMessage resp 85 | } 86 | where 87 | resp = ReadResp { readResult = putField flag 88 | , readNextNumber = putField num 89 | , readEndOfStream = putField eos 90 | , readEvents = putField $ fmap (toEventRecord name) xs 91 | , readRespStream = putField $ streamName name 92 | } 93 | 94 | -------------------------------------------------------------------------------- 95 | parseOp :: MonadPlus m => Pkg -> m (Operation ReadEventsResp) 96 | parseOp Pkg{..} = 97 | case pkgCmd of 98 | 0x05 -> 99 | case runGet decodeMessage pkgPayload of 100 | Right r -> do 101 | let streamName = StreamName $ getField $ readStreamId r 102 | startNum = EventNumber $ getField $ readStartNum r 103 | batchSize = getField $ readBatchSize r 104 | 105 | return $ Operation pkgId 106 | $ ReadEvents streamName (Batch startNum batchSize) 107 | _ -> mzero 108 | _ -> mzero 109 | 110 | -------------------------------------------------------------------------------- 111 | parseResp :: MonadPlus m => Pkg -> m (Response ReadEventsResp) 112 | parseResp Pkg{..} = 113 | case pkgCmd of 114 | 0x06 -> 115 | case runGet decodeMessage pkgPayload of 116 | Right r -> do 117 | let flag = getField $ readResult r 118 | nextNum = EventNumber $ getField $ readNextNumber r 119 | eos = getField $ readEndOfStream r 120 | name = StreamName $ getField $ readRespStream r 121 | 122 | xs <- traverse fromEventRecord $ getField $ readEvents r 123 | 124 | return $ Response pkgId 125 | $ ReadEventsResp name xs flag nextNum eos 126 | _ -> mzero 127 | _ -> mzero 128 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Message/WriteEvents.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Protocol.Message.WriteEvents 7 | -- Copyright : (C) 2017 Yorick Laupa 8 | -- License : (see the file LICENSE) 9 | -- 10 | -- Maintainer : Yorick Laupa 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Protocol.Message.WriteEvents 16 | ( createPkg 17 | , createRespPkg 18 | , parseOp 19 | , parseResp 20 | ) where 21 | 22 | -------------------------------------------------------------------------------- 23 | import Data.List.NonEmpty hiding (toList) 24 | 25 | -------------------------------------------------------------------------------- 26 | import Data.ProtocolBuffers hiding (encode, decode) 27 | import Data.Serialize hiding (Result) 28 | import Lambda.Prelude 29 | 30 | -------------------------------------------------------------------------------- 31 | import Protocol.Operation 32 | import Protocol.Package 33 | import Protocol.Types 34 | 35 | -------------------------------------------------------------------------------- 36 | data EventMsg = 37 | EventMsg { msgId :: Required 1 (Value ByteString) 38 | , msgType :: Required 2 (Value Text) 39 | , msgData :: Required 3 (Value ByteString) 40 | , msgMetadata :: Optional 4 (Value ByteString) 41 | } deriving (Generic, Show) 42 | 43 | -------------------------------------------------------------------------------- 44 | instance Encode EventMsg 45 | instance Decode EventMsg 46 | 47 | -------------------------------------------------------------------------------- 48 | data WriteReq = 49 | WriteReq { writeStreamId :: Required 1 (Value Text) 50 | , writeExpectedVersion :: Required 2 (Value Int32) 51 | , writeMsgs :: Repeated 3 (Message EventMsg) 52 | } deriving (Generic, Show) 53 | 54 | -------------------------------------------------------------------------------- 55 | instance Encode WriteReq 56 | instance Decode WriteReq 57 | 58 | -------------------------------------------------------------------------------- 59 | data WriteResp = 60 | WriteResp { writeResult :: Required 1 (Enumeration WriteResultFlag) 61 | , writeNextNumber :: Required 2 (Value Int32) 62 | } deriving (Generic, Show) 63 | 64 | -------------------------------------------------------------------------------- 65 | instance Encode WriteResp 66 | instance Decode WriteResp 67 | 68 | -------------------------------------------------------------------------------- 69 | verInt32 :: ExpectedVersion -> Int32 70 | verInt32 AnyVersion = -2 71 | verInt32 NoStream = -1 72 | verInt32 StreamExists = 0 73 | verInt32 (ExactVersion num) = let EventNumber n = num in n 74 | 75 | -------------------------------------------------------------------------------- 76 | int32ver :: Int32 -> ExpectedVersion 77 | int32ver (-2) = AnyVersion 78 | int32ver (-1) = NoStream 79 | int32ver 0 = StreamExists 80 | int32ver n = ExactVersion $ EventNumber n 81 | 82 | -------------------------------------------------------------------------------- 83 | createPkg :: PkgId -> StreamName -> ExpectedVersion -> NonEmpty Event -> Pkg 84 | createPkg pid name ver xs = 85 | Pkg { pkgCmd = 0x03 86 | , pkgId = pid 87 | , pkgPayload = runPut $ encodeMessage req 88 | } 89 | where 90 | req = WriteReq { writeStreamId = putField $ streamName name 91 | , writeExpectedVersion = putField $ verInt32 ver 92 | , writeMsgs = putField $ toList $ fmap toMsg xs 93 | } 94 | 95 | toMsg e = 96 | EventMsg { msgId = putField $ eventIdBytes $ eventId e 97 | , msgType = putField $ eventTypeText $ eventType e 98 | , msgData = putField $ dataBytes $ eventPayload e 99 | , msgMetadata = putField $ fmap encode $ eventMetadata e 100 | } 101 | 102 | -------------------------------------------------------------------------------- 103 | createRespPkg :: PkgId -> EventNumber -> WriteResultFlag -> Pkg 104 | createRespPkg pid (EventNumber n) flag = 105 | Pkg { pkgCmd = 0x04 106 | , pkgId = pid 107 | , pkgPayload = runPut $ encodeMessage resp 108 | } 109 | where 110 | resp = WriteResp { writeResult = putField flag 111 | , writeNextNumber = putField n 112 | } 113 | 114 | -------------------------------------------------------------------------------- 115 | parseOp :: MonadPlus m => Pkg -> m (Operation WriteEventsResp) 116 | parseOp Pkg{..} = 117 | case pkgCmd of 118 | 0x03 -> 119 | case runGet decodeMessage pkgPayload of 120 | Right r -> do 121 | let name = StreamName $ getField $ writeStreamId r 122 | ver = int32ver $ getField $ writeExpectedVersion r 123 | xs = getField $ writeMsgs r 124 | 125 | toEvt msg = do 126 | eid <- case guidFromBytes $ getField $ msgId msg of 127 | Just guid -> return $ EventId guid 128 | _ -> mzero 129 | 130 | let dat = getField $ msgMetadata msg 131 | return Event { eventId = eid 132 | , eventType = EventType $ getField $ msgType msg 133 | , eventPayload = Data $ getField $ msgData msg 134 | , eventMetadata = eitherMaybe . decode =<< dat 135 | } 136 | 137 | evts <- traverse toEvt xs 138 | safeEvts <- maybe mzero return $ nonEmpty evts 139 | 140 | return $ Operation pkgId $ WriteEvents name ver safeEvts 141 | _ -> mzero 142 | _ -> mzero 143 | 144 | -------------------------------------------------------------------------------- 145 | parseResp :: MonadPlus m => Pkg -> m (Response WriteEventsResp) 146 | parseResp Pkg{..} = 147 | case pkgCmd of 148 | 0x04 -> 149 | case runGet decodeMessage pkgPayload of 150 | Right r -> do 151 | let flag = getField $ writeResult r 152 | nxt = EventNumber $ getField $ writeNextNumber r 153 | return $ Response pkgId $ WriteEventsResp nxt flag 154 | _ -> mzero 155 | _ -> mzero 156 | 157 | -------------------------------------------------------------------------------- 158 | eitherMaybe :: Either e a -> Maybe a 159 | eitherMaybe (Right a) = Just a 160 | eitherMaybe _ = Nothing 161 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Operation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Protocol.Operation 6 | -- Copyright : (C) 2017 Yorick Laupa 7 | -- License : (see the file LICENSE) 8 | -- 9 | -- Maintainer : Yorick Laupa 10 | -- Stability : provisional 11 | -- Portability : non-portable 12 | -- 13 | -------------------------------------------------------------------------------- 14 | module Protocol.Operation where 15 | 16 | -------------------------------------------------------------------------------- 17 | import Data.List.NonEmpty 18 | 19 | -------------------------------------------------------------------------------- 20 | import Lambda.Prelude 21 | 22 | -------------------------------------------------------------------------------- 23 | import Protocol.Package 24 | import Protocol.Types 25 | 26 | -------------------------------------------------------------------------------- 27 | data Request a where 28 | WriteEvents :: StreamName 29 | -> ExpectedVersion 30 | -> NonEmpty Event 31 | -> Request WriteEventsResp 32 | 33 | ReadEvents :: StreamName 34 | -> Batch 35 | -> Request ReadEventsResp 36 | 37 | -------------------------------------------------------------------------------- 38 | data WriteEventsResp = 39 | WriteEventsResp EventNumber WriteResultFlag 40 | 41 | -------------------------------------------------------------------------------- 42 | data ReadEventsResp = 43 | ReadEventsResp StreamName [SavedEvent] ReadResultFlag EventNumber Bool 44 | 45 | -------------------------------------------------------------------------------- 46 | data Operation a = 47 | Operation { operationId :: PkgId 48 | , operationType :: Request a 49 | } 50 | 51 | -------------------------------------------------------------------------------- 52 | data SomeOperation = forall a. Typeable a => SomeOperation (Operation a) 53 | 54 | -------------------------------------------------------------------------------- 55 | data Response a = 56 | Response { responseId :: PkgId 57 | , responseType :: a 58 | } 59 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Package.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE StrictData #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Protocol.Package 6 | -- Copyright : (C) 2017 Yorick Laupa 7 | -- License : (see the file LICENSE) 8 | -- 9 | -- Maintainer : Yorick Laupa 10 | -- Stability : provisional 11 | -- Portability : non-portable 12 | -- 13 | -------------------------------------------------------------------------------- 14 | module Protocol.Package where 15 | 16 | -------------------------------------------------------------------------------- 17 | import Lambda.Prelude 18 | import Data.Serialize 19 | import Data.UUID 20 | import Data.UUID.V4 21 | 22 | -------------------------------------------------------------------------------- 23 | newtype Cmd = Cmd Word8 deriving (Eq, Ord, Enum, Num, Show) 24 | 25 | -------------------------------------------------------------------------------- 26 | instance Serialize Cmd where 27 | put (Cmd w) = putWord8 w 28 | get = Cmd <$> getWord8 29 | 30 | -------------------------------------------------------------------------------- 31 | newtype PkgId = PkgId UUID deriving (Eq, Ord, Hashable) 32 | 33 | -------------------------------------------------------------------------------- 34 | instance Show PkgId where 35 | show (PkgId pid) = [i|[#{pid}]|] 36 | 37 | -------------------------------------------------------------------------------- 38 | freshPkgId :: MonadIO m => m PkgId 39 | freshPkgId = liftIO (PkgId <$> nextRandom) 40 | 41 | -------------------------------------------------------------------------------- 42 | instance Serialize PkgId where 43 | put (PkgId uuid) = 44 | putLazyByteString $ toByteString uuid 45 | 46 | get = do 47 | bs <- getLazyByteString 16 48 | case fromByteString bs of 49 | Just uuid -> return $ PkgId uuid 50 | Nothing -> mzero 51 | 52 | -------------------------------------------------------------------------------- 53 | newtype PkgPrefix = PkgPrefix Word32 deriving Num 54 | 55 | -------------------------------------------------------------------------------- 56 | pkgPrefixIntegral :: Integral a => PkgPrefix -> a 57 | pkgPrefixIntegral (PkgPrefix w) = fromIntegral w 58 | 59 | -------------------------------------------------------------------------------- 60 | instance Serialize PkgPrefix where 61 | put (PkgPrefix w) = putWord32le w 62 | get = PkgPrefix <$> getWord32le 63 | 64 | -------------------------------------------------------------------------------- 65 | data Pkg = 66 | Pkg { pkgCmd :: Cmd 67 | , pkgId :: PkgId 68 | , pkgPayload :: ByteString 69 | } deriving Eq 70 | 71 | -------------------------------------------------------------------------------- 72 | pkgPrefix :: Pkg -> PkgPrefix 73 | pkgPrefix Pkg{..} = PkgPrefix (1 + 16 + (fromIntegral $ length pkgPayload)) 74 | 75 | -------------------------------------------------------------------------------- 76 | instance Serialize Pkg where 77 | put pkg = do 78 | put $ pkgPrefix pkg 79 | put $ pkgCmd pkg 80 | put $ pkgId pkg 81 | putByteString $ pkgPayload pkg 82 | 83 | get = 84 | Pkg <$> get 85 | <*> get 86 | <*> (remaining >>= getBytes) 87 | 88 | -------------------------------------------------------------------------------- 89 | instance Show Pkg where 90 | show Pkg{..} = [i|Pkg #{pkgId} #{pkgCmd}|] 91 | 92 | -------------------------------------------------------------------------------- 93 | heartbeatRequest :: IO Pkg 94 | heartbeatRequest = do 95 | pid <- freshPkgId 96 | return Pkg { pkgCmd = 0x01 97 | , pkgId = pid 98 | , pkgPayload = mempty 99 | } 100 | 101 | -------------------------------------------------------------------------------- 102 | heartbeatResponse :: PkgId -> Pkg 103 | heartbeatResponse pid = 104 | Pkg { pkgCmd = 0x02 105 | , pkgId = pid 106 | , pkgPayload = mempty 107 | } 108 | -------------------------------------------------------------------------------- /lambda-protocol/library/Protocol/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Protocol.Types 5 | -- Copyright : (C) 2017 Yorick Laupa 6 | -- License : (see the file LICENSE) 7 | -- 8 | -- Maintainer : Yorick Laupa 9 | -- Stability : provisional 10 | -- Portability : non-portable 11 | -- 12 | -------------------------------------------------------------------------------- 13 | module Protocol.Types where 14 | 15 | -------------------------------------------------------------------------------- 16 | import Data.Serialize 17 | import Data.UUID hiding (fromString) 18 | import Data.UUID.V4 19 | import Lambda.Prelude 20 | 21 | -------------------------------------------------------------------------------- 22 | class FreshId ident where 23 | freshId :: MonadIO m => m ident 24 | 25 | -------------------------------------------------------------------------------- 26 | newtype Guid = Guid UUID deriving (Eq, Ord) 27 | 28 | -------------------------------------------------------------------------------- 29 | guidBytes :: Guid -> ByteString 30 | guidBytes (Guid u) = toStrict $ toByteString u 31 | 32 | -------------------------------------------------------------------------------- 33 | guidFromBytes :: ByteString -> Maybe Guid 34 | guidFromBytes = fmap Guid . fromByteString . fromStrict 35 | 36 | -------------------------------------------------------------------------------- 37 | instance Hashable Guid where 38 | hashWithSalt x (Guid g) = hashWithSalt x g 39 | 40 | -------------------------------------------------------------------------------- 41 | instance Serialize Guid where 42 | get = do 43 | bs <- get 44 | case fromByteString bs of 45 | Just uuid -> return $ Guid uuid 46 | Nothing -> mzero 47 | 48 | put (Guid uuid) = put (toByteString uuid) 49 | 50 | -------------------------------------------------------------------------------- 51 | instance Show Guid where 52 | show (Guid g) = show g 53 | 54 | -------------------------------------------------------------------------------- 55 | instance FreshId Guid where 56 | freshId = liftIO (Guid <$> nextRandom) 57 | 58 | -------------------------------------------------------------------------------- 59 | newtype Data = Data ByteString deriving Eq 60 | 61 | -------------------------------------------------------------------------------- 62 | instance IsString Data where 63 | fromString = Data . fromString 64 | 65 | -------------------------------------------------------------------------------- 66 | emptyData :: Data 67 | emptyData = Data mempty 68 | 69 | -------------------------------------------------------------------------------- 70 | dataBytes :: Data -> ByteString 71 | dataBytes (Data bs) = bs 72 | 73 | -------------------------------------------------------------------------------- 74 | instance Show Data where 75 | show _ = "Data(*Binary data*)" 76 | 77 | -------------------------------------------------------------------------------- 78 | instance Serialize Data where 79 | get = Data <$> get 80 | put (Data bs) = put bs 81 | 82 | -------------------------------------------------------------------------------- 83 | -- | Used to store a set a properties. One example is to be used as 'Event' 84 | -- metadata. 85 | newtype Properties = Properties (Map Text Text) deriving Eq 86 | 87 | -------------------------------------------------------------------------------- 88 | instance Monoid Properties where 89 | mempty = Properties mempty 90 | mappend (Properties a) (Properties b) = Properties $ mappend a b 91 | 92 | -------------------------------------------------------------------------------- 93 | instance Show Properties where 94 | show (Properties m) = show m 95 | 96 | -------------------------------------------------------------------------------- 97 | instance Serialize Properties where 98 | put (Properties m) = 99 | for_ (mapToList m) $ \(key, value) -> do 100 | put $ encodeUtf8 key 101 | put $ encodeUtf8 value 102 | 103 | get = 104 | let action = do 105 | (,) <$> fmap decodeUtf8 get 106 | <*> fmap decodeUtf8 get in 107 | (Properties . mapFromList) <$> some action 108 | 109 | -------------------------------------------------------------------------------- 110 | -- | Retrieves a value associated with the given key. 111 | property :: MonadPlus m => Text -> Properties -> m Text 112 | property k (Properties m) = 113 | case lookup k m of 114 | Nothing -> mzero 115 | Just v -> return v 116 | 117 | -------------------------------------------------------------------------------- 118 | -- | Builds a 'Properties' with a single pair of key-value. 119 | singleton :: Text -> Text -> Properties 120 | singleton k v = setProperty k v mempty 121 | 122 | -------------------------------------------------------------------------------- 123 | -- | Adds a pair of key-value into given 'Properties'. 124 | setProperty :: Text -> Text -> Properties -> Properties 125 | setProperty key value (Properties m) = Properties $ insertMap key value m 126 | 127 | -------------------------------------------------------------------------------- 128 | -- | Returns all associated key-value pairs as a list. 129 | properties :: Properties -> [(Text, Text)] 130 | properties (Properties m) = mapToList m 131 | 132 | -------------------------------------------------------------------------------- 133 | -- | Used to identify an event. 134 | newtype EventId = EventId Guid 135 | deriving ( Show 136 | , Eq 137 | , Ord 138 | , Serialize 139 | , Hashable 140 | ) 141 | 142 | -------------------------------------------------------------------------------- 143 | instance FreshId EventId where 144 | freshId = EventId <$> freshId 145 | 146 | -------------------------------------------------------------------------------- 147 | eventIdBytes :: EventId -> ByteString 148 | eventIdBytes (EventId g) = guidBytes g 149 | 150 | -------------------------------------------------------------------------------- 151 | -- | Represents a stream name. 152 | newtype StreamName = StreamName { streamName :: Text } deriving (Eq, Ord) 153 | 154 | -------------------------------------------------------------------------------- 155 | instance Hashable StreamName where 156 | hashWithSalt x (StreamName n) = hashWithSalt x n 157 | 158 | -------------------------------------------------------------------------------- 159 | instance Show StreamName where 160 | show (StreamName s) = show s 161 | 162 | -------------------------------------------------------------------------------- 163 | instance Serialize StreamName where 164 | get = (StreamName . decodeUtf8) <$> get 165 | 166 | put (StreamName n) = put $ encodeUtf8 n 167 | 168 | -------------------------------------------------------------------------------- 169 | instance IsString StreamName where 170 | fromString = StreamName . fromString 171 | 172 | -------------------------------------------------------------------------------- 173 | -- | Used to identity the type of an 'Event'. 174 | newtype EventType = EventType Text deriving Eq 175 | 176 | -------------------------------------------------------------------------------- 177 | instance Serialize EventType where 178 | get = (EventType . decodeUtf8) <$> get 179 | 180 | put (EventType tpe) = put $ encodeUtf8 tpe 181 | 182 | -------------------------------------------------------------------------------- 183 | eventTypeText :: EventType -> Text 184 | eventTypeText (EventType t) = t 185 | 186 | -------------------------------------------------------------------------------- 187 | instance Show EventType where 188 | show (EventType t) = show t 189 | 190 | -------------------------------------------------------------------------------- 191 | instance IsString EventType where 192 | fromString = EventType . fromString 193 | 194 | -------------------------------------------------------------------------------- 195 | -- | Encapsulates an event which is about to be saved. 196 | data Event = 197 | Event { eventType :: EventType 198 | , eventId :: EventId 199 | , eventPayload :: Data 200 | , eventMetadata :: Maybe Properties 201 | } deriving (Show, Eq) 202 | 203 | -------------------------------------------------------------------------------- 204 | instance Serialize Event where 205 | get = 206 | Event <$> get 207 | <*> get 208 | <*> get 209 | <*> get 210 | 211 | put Event{..} = do 212 | put eventType 213 | put eventId 214 | put eventPayload 215 | put eventMetadata 216 | 217 | -------------------------------------------------------------------------------- 218 | -- | Represents an event index in a stream. 219 | newtype EventNumber = EventNumber Int32 deriving (Eq, Ord, Num, Enum, Show) 220 | 221 | -------------------------------------------------------------------------------- 222 | instance Serialize EventNumber where 223 | get = fromIntegral <$> getWord32le 224 | 225 | put (EventNumber n) = putWord32le (fromIntegral n) 226 | 227 | -------------------------------------------------------------------------------- 228 | -- | Represents an event that's saved into the event store. 229 | data SavedEvent = 230 | SavedEvent { eventNumber :: EventNumber 231 | , savedEvent :: Event 232 | } deriving Show 233 | 234 | -------------------------------------------------------------------------------- 235 | instance Serialize SavedEvent where 236 | get = 237 | SavedEvent <$> get 238 | <*> get 239 | 240 | put SavedEvent{..} = do 241 | put eventNumber 242 | put savedEvent 243 | 244 | -------------------------------------------------------------------------------- 245 | -- | The purpose of 'ExpectedVersion' is to make sure a certain stream state is 246 | -- at an expected point in order to carry out a write. 247 | data ExpectedVersion 248 | = AnyVersion 249 | -- Stream is a any given state. 250 | | NoStream 251 | -- Stream shouldn't exist. 252 | | StreamExists 253 | -- Stream should exist. 254 | | ExactVersion EventNumber 255 | -- Stream should be at givent event number. 256 | deriving Show 257 | 258 | -------------------------------------------------------------------------------- 259 | -- | Represents batch information needed to read a stream. 260 | data Batch = 261 | Batch { batchFrom :: EventNumber 262 | , batchSize :: Int32 263 | } 264 | 265 | -------------------------------------------------------------------------------- 266 | -- | Starts a 'Batch' from a given point. The batch size is set to default, 267 | -- which is 500. 268 | startFrom :: EventNumber -> Batch 269 | startFrom from = Batch from 500 270 | 271 | -------------------------------------------------------------------------------- 272 | data WriteResultFlag 273 | = WriteSuccess 274 | | WriteWrongExpectedVersion 275 | deriving (Eq, Enum, Show) 276 | 277 | -------------------------------------------------------------------------------- 278 | data ReadResultFlag 279 | = ReadSuccess 280 | | ReadNoStream 281 | deriving (Eq, Enum, Show) 282 | 283 | -------------------------------------------------------------------------------- 284 | data Position = 285 | Position { preparePos :: Int 286 | , commitPos :: Int 287 | } 288 | -------------------------------------------------------------------------------- /lambda-protocol/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | category: Other 5 | description: lambda-protocol is a new Haskeleton package. 6 | extra-source-files: 7 | - CHANGELOG.md 8 | - LICENSE.md 9 | - package.yaml 10 | - README.md 11 | - stack.yaml 12 | ghc-options: -Wall 13 | github: YoEight/lambda-protocol 14 | default-extensions: 15 | - NoImplicitPrelude 16 | - OverloadedStrings 17 | - QuasiQuotes 18 | library: 19 | default-extensions: 20 | - GeneralizedNewtypeDeriving 21 | dependencies: 22 | - base >=4.9 && <5 23 | - protobuf 24 | - lambda-prelude 25 | - uuid 26 | - cereal 27 | - hashable 28 | source-dirs: library 29 | license: MIT 30 | maintainer: Yorick Laupa 31 | name: lambda-protocol 32 | synopsis: A new Haskeleton package. 33 | tests: 34 | lambda-protocol-test-suite: 35 | dependencies: 36 | - base 37 | - lambda-protocol 38 | - tasty 39 | - tasty-hspec 40 | - classy-prelude 41 | - directory 42 | - cereal 43 | ghc-options: 44 | - -rtsopts 45 | - -threaded 46 | - -with-rtsopts=-N 47 | main: Main.hs 48 | source-dirs: test-suite 49 | version: '0.0.0' 50 | -------------------------------------------------------------------------------- /lambda-protocol/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.22 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /lambda-protocol/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | import ClassyPrelude 13 | import qualified Test.Tasty 14 | import Test.Tasty.Hspec 15 | 16 | -------------------------------------------------------------------------------- 17 | import qualified Test.Serialize as Serialize 18 | 19 | -------------------------------------------------------------------------------- 20 | main :: IO () 21 | main = do 22 | tree <- sequence [ testSpec "Serialize" Serialize.spec ] 23 | let test = Test.Tasty.testGroup "protocol" tree 24 | Test.Tasty.defaultMain test 25 | -------------------------------------------------------------------------------- /lambda-protocol/test-suite/Test/Common.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Test.Common 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Test.Common where 13 | 14 | -------------------------------------------------------------------------------- 15 | import ClassyPrelude 16 | import System.Directory 17 | 18 | -------------------------------------------------------------------------------- 19 | freshFile :: FilePath -> IO FilePath 20 | freshFile p = do 21 | let path = "trash/" ++ p 22 | createDirectoryIfMissing True "trash" 23 | whenM (doesFileExist path) $ 24 | removeFile path 25 | 26 | return path 27 | -------------------------------------------------------------------------------- /lambda-protocol/test-suite/Test/Serialize.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Test.Serialize 4 | -- Copyright : (C) 2017 Yorick Laupa 5 | -- License : (see the file LICENSE) 6 | -- 7 | -- Maintainer : Yorick Laupa 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -------------------------------------------------------------------------------- 12 | module Test.Serialize (spec) where 13 | 14 | -------------------------------------------------------------------------------- 15 | import ClassyPrelude 16 | import Data.Serialize 17 | import Protocol.Types 18 | import Test.Tasty.Hspec 19 | 20 | -------------------------------------------------------------------------------- 21 | import Test.Common 22 | 23 | -------------------------------------------------------------------------------- 24 | spec :: Spec 25 | spec = do 26 | specify "StreamName" $ do 27 | path <- freshFile "stream" 28 | writeFile path (encode $ StreamName "stream") 29 | bs <- readFile path 30 | 31 | decode bs `shouldBe` (Right $ StreamName "stream") 32 | 33 | specify "EventType" $ do 34 | path <- freshFile "eventtype" 35 | writeFile path (encode $ EventType "type") 36 | bs <- readFile path 37 | 38 | decode bs `shouldBe` (Right $ EventType "type") 39 | 40 | specify "EventId" $ do 41 | eid <- freshId 42 | path <- freshFile "eventid" 43 | writeFile path (encode eid) 44 | bs <- readFile path 45 | 46 | decode bs `shouldBe` Right (eid :: EventId) 47 | 48 | specify "Data" $ do 49 | path <- freshFile "data" 50 | writeFile path $ encode $ Data "data" 51 | bs <- readFile path 52 | 53 | decode bs `shouldBe` (Right $ Data "data") 54 | 55 | specify "Properties" $ do 56 | path <- freshFile "properties" 57 | let ps = setProperty "foo" "bar" $ 58 | setProperty "tit" "tot" mempty 59 | 60 | writeFile path $ encode ps 61 | bs <- readFile path 62 | 63 | decode bs `shouldBe` Right ps 64 | 65 | specify "Event" $ do 66 | eid <- freshId 67 | path <- freshFile "event" 68 | let ps = setProperty "foo" "bar" $ 69 | setProperty "tit" "tot" mempty 70 | 71 | evt = Event { eventType = "type" 72 | , eventId = eid 73 | , eventPayload = Data "data" 74 | , eventMetadata = Just ps 75 | } 76 | 77 | writeFile path (encode evt) 78 | bs <- readFile path 79 | 80 | decode bs `shouldBe` Right evt 81 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: nightly-2017-08-12 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - lambda-bus 40 | - lambda-client 41 | - lambda-logger 42 | - lambda-node 43 | - lambda-prelude 44 | - lambda-protocol 45 | 46 | # Dependency packages to be pulled from upstream that are not in the resolver 47 | # (e.g., acme-missiles-0.3) 48 | extra-deps: 49 | - protobuf-0.2.1.1 50 | 51 | # Override default flag values for local packages and extra-deps 52 | flags: {} 53 | 54 | # Extra package databases containing global packages 55 | extra-package-dbs: [] 56 | 57 | # Control whether we use the GHC we find on the path 58 | # system-ghc: true 59 | # 60 | # Require a specific version of stack, using version ranges 61 | # require-stack-version: -any # Default 62 | # require-stack-version: ">=1.5" 63 | # 64 | # Override the architecture used by stack, especially useful on Windows 65 | # arch: i386 66 | # arch: x86_64 67 | # 68 | # Extra directories used by stack for building 69 | # extra-include-dirs: [/path/to/dir] 70 | # extra-lib-dirs: [/path/to/dir] 71 | # 72 | # Allow a newer minor version of GHC than the snapshot specifies 73 | # compiler-check: newer-minor 74 | --------------------------------------------------------------------------------