diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Matthieu Monsch (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Matthieu Monsch nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,1 @@
+# Distributed tracing
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/ZipkinExample.hs b/app/ZipkinExample.hs
new file mode 100644
--- /dev/null
+++ b/app/ZipkinExample.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | A simple tracing example which outputs traces to stdout.
+--
+-- It also showcases how to trace calls across threads.
+module Main where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (void)
+import Monitor.Tracing
+import qualified Monitor.Tracing.Zipkin as Zipkin
+import qualified Net.IPv4 as IPv4
+
+example1 :: MonadTrace m => m ()
+example1 = Zipkin.rootSpan Zipkin.Deny "example1" $ do
+  Zipkin.annotate "TEST_LOG0"
+  Zipkin.localSpan "nested1" $ Zipkin.tag "TEST_TAG1" "12"
+  Zipkin.localSpan "nested2" $ do
+    Zipkin.tag "TEST_TAG2" "a.2"
+    Zipkin.localSpan "nestednsted" $ Zipkin.tag "TEST_TAG3" ""
+
+example2 :: (MonadTrace m, MonadUnliftIO m) => m ()
+example2 = Zipkin.rootSpan Zipkin.Accept "something" $ do
+  Zipkin.annotate "log2"
+  Zipkin.tag "tag2" "def"
+  liftIO $ threadDelay 100000
+  Zipkin.localSpan "A" $ do
+    void $ tracedForkIO $ Zipkin.localSpan "aa" $ do
+      liftIO $ threadDelay 20000
+      Zipkin.annotate "log1"
+      Zipkin.tag "tag1" "def"
+    liftIO $ threadDelay 10000
+  Zipkin.localSpan "B" $ liftIO $ threadDelay 30000
+
+main :: IO ()
+main = do
+  zipkin <- Zipkin.new $ Zipkin.defaultSettings
+    { Zipkin.settingsEndpoint = Just $ Zipkin.defaultEndpoint
+      { Zipkin.endpointService = Just "print-spans"
+      , Zipkin.endpointIPv4 = Just IPv4.localhost }
+    , Zipkin.settingsHost = "localhost" }
+  Zipkin.run zipkin example1
+  Zipkin.run zipkin example2
+  Zipkin.publish zipkin
diff --git a/src/Control/Monad/Trace.hs b/src/Control/Monad/Trace.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Trace.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.
+
+-- | The 'TraceT' class.
+module Control.Monad.Trace (
+  TraceT, runTraceT,
+  Tracer(..),
+  Tags, Logs, Interval(..),
+  newTracer
+) where
+
+import Prelude hiding (span)
+
+import Control.Monad.Trace.Class
+import Control.Monad.Trace.Internal
+
+import Control.Applicative ((<|>))
+import Control.Concurrent.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan)
+import Control.Exception (finally)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Reader (ReaderT(..), ask, asks, local, runReaderT)
+import Control.Monad.Reader.Class (MonadReader)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import qualified Data.Aeson as JSON
+import Data.List (sortOn)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock (NominalDiffTime)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import UnliftIO (MonadUnliftIO, UnliftIO(..), askUnliftIO, withRunInIO, withUnliftIO)
+
+-- | A collection of span tags.
+type Tags = Map Key JSON.Value
+
+-- | A collection of span logs, sorted in chronological order.
+type Logs = [(POSIXTime, Key, JSON.Value)]
+
+-- | Timing information about a span.
+data Interval = Interval
+  { intervalStart :: !POSIXTime
+  , intervalDuration :: !NominalDiffTime
+  }
+
+-- | A tracer collects spans emitted inside 'TraceT'.
+data Tracer = Tracer
+  { tracerChannel :: TChan (Span, Tags, Logs, Interval)
+  , tracerPendingCount :: TVar Int
+  }
+
+-- | Creates a new 'Tracer'.
+newTracer :: MonadIO m => m Tracer
+newTracer = liftIO $ Tracer <$> newTChanIO <*> newTVarIO 0
+
+data Scope = Scope
+  { scopeTracer :: !Tracer
+  , scopeSpan :: !(Maybe Span)
+  , scopeTags :: !(Maybe (TVar Tags))
+  , scopeLogs :: !(Maybe (TVar Logs))
+  }
+
+-- | Asynchronous trace collection monad.
+newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
+
+instance MonadReader r m => MonadReader r (TraceT m) where
+  ask = lift ask
+  local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r
+
+instance MonadUnliftIO m => MonadTrace (TraceT m) where
+  trace bldr (TraceT reader) = TraceT $ do
+    parentScope <- ask
+    let
+      mbParentCtx = spanContext <$> scopeSpan parentScope
+      mbTraceID = contextTraceID <$> mbParentCtx
+    spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr
+    traceID <- maybe (liftIO randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
+    tagsTV <- liftIO $ newTVarIO $ builderTags bldr
+    logsTV <- liftIO $ newTVarIO []
+    let
+      baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx
+      ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)
+      spn = Span (builderName bldr) ctx (builderReferences bldr)
+      tracer = scopeTracer parentScope
+      childScope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)
+    withRunInIO $ \run -> do
+      start <- getPOSIXTime
+      atomically $ modifyTVar' (tracerPendingCount tracer) (+1)
+      run (local (const childScope) reader) `finally` do
+        end <- getPOSIXTime
+        atomically $ do
+          modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)
+          tags <- readTVar tagsTV
+          logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV
+          writeTChan (tracerChannel tracer) (spn, tags, logs, Interval start (end - start))
+
+  activeSpan = TraceT $ asks scopeSpan
+
+  addSpanEntry key (TagValue val) = TraceT $ asks scopeTags >>= \case
+    Nothing -> pure ()
+    Just tv -> liftIO $ atomically $ modifyTVar' tv $ Map.insert key val
+  addSpanEntry key (LogValue val maybeTime)  = TraceT $ asks scopeLogs >>= \case
+    Nothing -> pure ()
+    Just tv -> do
+      time <- case maybeTime of
+        Nothing -> liftIO getPOSIXTime
+        Just time' -> pure time'
+      liftIO $ atomically $ modifyTVar' tv ((time, key, val) :)
+
+instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where
+  askUnliftIO = TraceT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . traceTReader ))
+
+-- | Trace an action.
+runTraceT :: TraceT m a -> Tracer -> m a
+runTraceT (TraceT reader) tracer = runReaderT reader (Scope tracer Nothing Nothing Nothing)
diff --git a/src/Control/Monad/Trace/Class.hs b/src/Control/Monad/Trace/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Trace/Class.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | The 'MonadTrace' class
+module Control.Monad.Trace.Class (
+  MonadTrace(..),
+  Builder(..), Name, SpanID, TraceID, Reference(..), builder,
+  Span(..), Context(..),
+  Key, Value, tagDoubleValue, tagInt64Value, tagTextValue, logValue, logValueAt
+) where
+
+import Control.Monad.Trace.Internal
+
+import Control.Monad.Except (ExceptT(..))
+import Control.Monad.Identity (Identity(..))
+import Control.Monad.Reader (ReaderT(..))
+import qualified Control.Monad.RWS.Lazy as RWS.Lazy
+import qualified Control.Monad.RWS.Strict as RWS.Strict
+import qualified Control.Monad.State.Lazy as State.Lazy
+import qualified Control.Monad.State.Strict as State.Strict
+import Control.Monad.Trans.Class (MonadTrans, lift)
+import qualified Control.Monad.Writer.Lazy as Writer.Lazy
+import qualified Control.Monad.Writer.Strict as Writer.Strict
+import qualified Data.Aeson as JSON
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.String (IsString(..))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime)
+
+-- | A monad capable of generating traces.
+--
+-- There are currently two instances of this monad:
+--
+-- * 'Control.Monad.Trace.TraceT', which emits spans for each trace in 'IO' and is meant to be used
+-- in production.
+-- * 'Identity', where tracing is a no-op and allows testing traced functions without any overhead
+-- or complex setup.
+class Monad m => MonadTrace m where
+
+  -- | Trace an action, wrapping it inside a new span.
+  trace :: Builder -> m a -> m a
+
+  -- | Extracts the currently active span, or 'Nothing' if the action is not being traced.
+  activeSpan :: m (Maybe Span)
+  default activeSpan :: (MonadTrace n, MonadTrans t, m ~ t n) => m (Maybe Span)
+  activeSpan = lift activeSpan
+
+  -- | Adds information to the active span, if present.
+  addSpanEntry :: Key -> Value -> m ()
+  default addSpanEntry :: (MonadTrace n, MonadTrans t, m ~ t n) => Key -> Value -> m ()
+  addSpanEntry key = lift . addSpanEntry key
+
+instance (Monad m, MonadTrace m) => MonadTrace (ExceptT e m) where
+  trace name (ExceptT actn) = ExceptT $ trace name actn
+
+instance (Monad m, MonadTrace m) => MonadTrace (ReaderT r m) where
+  trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)
+
+instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Lazy.RWST r w s m) where
+  trace name (RWS.Lazy.RWST actn) = RWS.Lazy.RWST $ \r s -> trace name (actn r s)
+
+instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Strict.RWST r w s m) where
+  trace name (RWS.Strict.RWST actn) = RWS.Strict.RWST $ \r s -> trace name (actn r s)
+
+instance (Monad m, MonadTrace m) => MonadTrace (State.Lazy.StateT s m) where
+  trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)
+
+instance (Monad m, MonadTrace m) => MonadTrace (State.Strict.StateT s m) where
+  trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)
+
+instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where
+  trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn
+
+instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Strict.WriterT w m) where
+  trace name (Writer.Strict.WriterT actn) = Writer.Strict.WriterT $ trace name actn
+
+instance MonadTrace Identity where
+  trace _ = id
+  activeSpan = pure Nothing
+  addSpanEntry _ _ = pure ()
+
+-- Creating traces
+
+-- | A trace builder.
+--
+-- Note that 'Builder' has an 'IsString' instance, producing a span with the given string as name,
+-- no additional references, tags, or baggages. This allows convenient creation of spans via the
+-- @OverloadedStrings@ pragma.
+data Builder = Builder
+  { builderName :: !Name
+  -- ^ Name of the generated span.
+  , builderTraceID :: !(Maybe TraceID)
+  -- ^ The trace ID of the generated span. If unset, the active span's trace ID will be used if
+  -- present, otherwise a new ID will be generated.
+  , builderSpanID :: !(Maybe SpanID)
+  -- ^ The ID of the generated span, otherwise the ID will be auto-generated.
+  , builderReferences :: !(Set Reference)
+  -- ^ Span references.
+  , builderTags :: !(Map Key JSON.Value)
+  -- ^ Initial set of tags.
+  , builderBaggages :: !(Map Key ByteString)
+  -- ^ Span context baggages.
+  } deriving Show
+
+-- | Returns a 'Builder' with the given input as name and all other fields empty.
+builder :: Name -> Builder
+builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty
+
+instance IsString Builder where
+  fromString = builder . T.pack
+
+-- Writing metadata
+
+-- | Generates a tag value from a double.
+tagDoubleValue :: Double -> Value
+tagDoubleValue = TagValue . JSON.toJSON
+
+-- | Generates a 64-bit integer tag value from any integer.
+tagInt64Value :: Integral a => a -> Value
+tagInt64Value = TagValue . (JSON.toJSON @Int64) . fromIntegral
+
+-- | Generates a Unicode text tag value.
+tagTextValue :: Text -> Value
+tagTextValue = TagValue . JSON.toJSON
+
+-- | Generates a log value with the time of writing as timestamp. Note that the value may be written
+-- later than it is created. For more control on the timestamp, use 'logValueAt'.
+logValue :: JSON.ToJSON a => a -> Value
+logValue v = LogValue (JSON.toJSON v) Nothing
+
+-- | Generates a log value with a custom time.
+logValueAt :: JSON.ToJSON a => POSIXTime -> a -> Value
+logValueAt t v = LogValue (JSON.toJSON v) (Just t)
diff --git a/src/Control/Monad/Trace/Internal.hs b/src/Control/Monad/Trace/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Trace/Internal.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Control.Monad.Trace.Internal (
+  TraceID(..), randomTraceID,
+  SpanID(..), randomSpanID,
+  Context(..),
+  Name,
+  Span(..),
+  Reference(..),
+  Key, Value(..)
+) where
+
+import Control.Monad (replicateM)
+import qualified Data.Aeson as JSON
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS.Char8
+import qualified Data.ByteString.Base16 as Base16
+import Data.Map.Strict (Map)
+import Data.Set (Set)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime)
+import System.Random (randomIO)
+
+-- | The name of a span.
+type Name = Text
+
+-- | The type of annotations' keys.
+--
+-- Keys starting with double underscores are reserved and should not be used.
+type Key = Text
+
+-- | A 128-bit trace identifier.
+newtype TraceID = TraceID ByteString deriving (Eq, Ord, Show)
+
+instance JSON.FromJSON TraceID where
+  parseJSON = JSON.withText "TraceID" $ \t -> case hexDecode t of
+    Just bs | BS.length bs == 16 -> pure $ TraceID bs
+    _ -> fail "invalid hex-encoded trace ID"
+
+instance JSON.ToJSON TraceID where
+  toJSON (TraceID bs) = JSON.toJSON $ hexEncode bs
+
+-- | Generates a random trace ID.
+randomTraceID :: IO TraceID
+randomTraceID = TraceID <$> randomID 16
+
+-- | A 64-bit span identifier.
+newtype SpanID = SpanID ByteString deriving (Eq, Ord, Show)
+
+instance JSON.FromJSON SpanID where
+  parseJSON = JSON.withText "SpanID" $ \t -> case hexDecode t of
+    Just bs | BS.length bs == 8 -> pure $ SpanID bs
+    _ -> fail "invalid hex-encoded span ID"
+
+instance JSON.ToJSON SpanID where
+  toJSON (SpanID bs) = JSON.toJSON $ hexEncode bs
+
+-- | Generates a random span ID.
+randomSpanID :: IO SpanID
+randomSpanID = SpanID <$> randomID 8
+
+-- | A fully qualified span identifier, containing both the ID of the trace the span belongs to and
+-- the span's ID. Span contexts can be exported (resp. imported) via their 'JSON.toJSON' (resp.
+-- 'JSON.fromJSON') instance.
+data Context = Context
+  { contextTraceID :: !TraceID
+  , contextSpanID :: !SpanID
+  , contextBaggages :: !(Map Key ByteString)
+  } deriving (Eq, Ord, Show)
+
+-- | A relationship between spans.
+--
+-- There are currently two types of references, both of which model direct causal relationships
+-- between a child and a parent. More background on references is available in the opentracing
+-- specification: https://github.com/opentracing/specification/blob/master/specification.md.
+data Reference
+  = ChildOf !SpanID
+  -- ^ 'ChildOf' references imply that the parent span depends on the child span in some capacity.
+  -- Note that this reference type is only valid within a single trace.
+  | FollowsFrom !Context
+  -- ^ If the parent does not depend on the child, we use a 'FollowsFrom' reference.
+  deriving (Eq, Ord, Show)
+
+-- | Metadata attached to a span.
+data Value
+  = TagValue !JSON.Value
+  | LogValue !JSON.Value !(Maybe POSIXTime)
+
+-- | A part of a trace.
+data Span = Span
+  { spanName :: !Name
+  , spanContext :: !Context
+  , spanReferences :: !(Set Reference)
+  }
+
+randomID :: Int -> IO ByteString
+randomID len = BS.pack <$> replicateM len randomIO
+
+hexDecode :: Text-> Maybe ByteString
+hexDecode t = case Base16.decode $ BS.Char8.pack $ T.unpack t of
+  (bs, trail) | BS.null trail -> Just bs
+  _ -> Nothing
+
+hexEncode :: ByteString -> Text
+hexEncode = T.pack . BS.Char8.unpack . Base16.encode
diff --git a/src/Monitor/Tracing.hs b/src/Monitor/Tracing.hs
new file mode 100644
--- /dev/null
+++ b/src/Monitor/Tracing.hs
@@ -0,0 +1,55 @@
+{-| Non-intrusive distributed tracing
+
+Let's assume for example we are interested in tracing the two following functions and publishing
+their traces to Zipkin:
+
+> listTaskIDs :: MonadIO m => m [Int] -- Returns a list of all task IDs.
+> fetchTasks :: MonadIO m => [Int] -> m [Task] -- Resolves IDs into tasks.
+
+We can do so simply by wrapping them inside a 'Monitor.Tracing.Zipkin.localSpan' call and adding a
+'MonadTrace' constraint:
+
+> listTaskIDs' :: (MonadIO m, MonadTrace m) => m [Int]
+> listTaskIDs' = localSpan "list-task-ids" listTaskIDs
+>
+> fetchTasks' :: (MonadIO m, MonadTrace m) => [Int] -> m [Task]
+> fetchTasks' = localSpan "fetch-tasks" . fetchTasks
+
+Spans will now automatically get generated and published each time these actions are run! Each
+publication will include various useful pieces of metadata, including lineage. For example, if we
+wrap the two above functions in a root span, the spans will correctly be nested:
+
+> main :: IO ()
+> main = do
+>   zipkin <- new defaultSettings
+>   tasks <- run zipkin $ rootSpan "list-tasks" (listTaskIDs' >>= fetchTasks')
+>   publish zipkin
+>   print tasks
+
+For clarity the above example imported all functions unqualified. In general, the recommended
+pattern when using this library is to import this module unqualified and the backend-specific module
+qualified. For example:
+
+> import Monitor.Tracing
+> import qualified Monitor.Tracing.Zipkin as Zipkin
+
+-}
+module Monitor.Tracing (
+  -- * Overview
+  MonadTrace, tracedForkIO,
+  -- * Convenience exports
+  MonadIO, liftIO, MonadUnliftIO, withRunInIO
+) where
+
+import Control.Monad.Trace.Class
+
+import Control.Concurrent (forkIO, ThreadId)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import UnliftIO (MonadUnliftIO, withRunInIO)
+
+-- | Starts a new span inside a new thread, returning the newly created thread's ID.
+--
+-- This convenience method around 'forkIO' and 'withRunInIO' is provided since getting insights into
+-- concurrent calls is one of the main benefits of tracing.
+tracedForkIO :: (MonadTrace m, MonadUnliftIO m) => m () -> m ThreadId
+tracedForkIO actn = withRunInIO $ \run -> forkIO $ run actn
diff --git a/src/Monitor/Tracing/Jaeger.hs b/src/Monitor/Tracing/Jaeger.hs
new file mode 100644
--- /dev/null
+++ b/src/Monitor/Tracing/Jaeger.hs
@@ -0,0 +1,7 @@
+{-| <https://www.jaegertracing.io/ Jaeger> trace publisher. -}
+module Monitor.Tracing.Jaeger (
+  Jaeger
+) where
+
+-- | Jaeger publisher, not implemented yet.
+data Jaeger
diff --git a/src/Monitor/Tracing/Zipkin.hs b/src/Monitor/Tracing/Zipkin.hs
new file mode 100644
--- /dev/null
+++ b/src/Monitor/Tracing/Zipkin.hs
@@ -0,0 +1,362 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+{-| <https://zipkin.apache.org/ Zipkin> trace publisher. -}
+module Monitor.Tracing.Zipkin (
+  -- * Set up the trace collector
+  Zipkin, new, Settings(..), defaultSettings, Endpoint(..), defaultEndpoint, run, publish,
+  -- * Record in-process spans
+  rootSpan, Sampling(..), localSpan,
+  -- * Record cross-process spans
+  B3, clientSpan, serverSpan, producerSpan, consumerSpan,
+  -- * Add metadata
+  tag, annotate, annotateAt
+) where
+
+import Control.Monad.Trace
+import Control.Monad.Trace.Class
+
+import Control.Applicative ((<|>))
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.STM (atomically, tryReadTChan)
+import Control.Monad (forever, void, when)
+import Control.Monad.Fix (fix)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Data.Aeson as JSON
+import Data.ByteString (ByteString)
+import Data.Time.Clock (NominalDiffTime)
+import Data.Foldable (toList)
+import Data.Int (Int64)
+import Data.IORef (modifyIORef, newIORef, readIORef)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)
+import Data.Monoid (Endo(..))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime)
+import Net.IPv4 (IPv4)
+import Net.IPv6 (IPv6)
+import Network.HTTP.Client (Manager, Request)
+import qualified Network.HTTP.Client as HTTP
+
+-- | Zipkin creating settings.
+data Settings = Settings
+  { settingsManager :: !(Maybe Manager)
+  -- ^ An optional HTTP manager to use for publishing spans on the Zipkin server.
+  , settingsHost :: !ByteString
+  -- ^ The Zipkin server host.
+  , settingsPort :: !Int
+  -- ^ The port the Zipkin server is listening on.
+  , settingsEndpoint :: !(Maybe Endpoint)
+  -- ^ Local endpoint used for all published spans.
+  , settingsPublishPeriod :: !NominalDiffTime
+  -- ^ If set to a positive value, traces will be flushed in the background every such period.
+  }
+
+-- | Creates 'Settings' pointing to a Zikpin server at host @"localhost"@ and port @9411@, without
+-- background flushing.
+defaultSettings :: Settings
+defaultSettings = Settings Nothing "localhost" 9411 Nothing 0
+
+-- | A Zipkin trace publisher.
+data Zipkin = Zipkin
+  { zipkinManager :: !Manager
+  , zipkinRequest :: !Request
+  , zipkinTracer :: !Tracer
+  , zipkinEndpoint :: !(Maybe Endpoint)
+  }
+
+flushSpans :: Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()
+flushSpans ept tracer req mgr = do
+  ref <- newIORef []
+  fix $ \loop -> atomically (tryReadTChan $ tracerChannel tracer) >>= \case
+    Nothing -> pure ()
+    Just (spn, tags, logs, itv) -> do
+      when (isSampled spn) $ modifyIORef ref (ZipkinSpan ept spn tags logs itv:)
+      loop
+  spns <- readIORef ref
+  let req' = req { HTTP.requestBody = HTTP.RequestBodyLBS $ JSON.encode spns }
+  void $ HTTP.httpLbs req' mgr
+
+-- | Creates a 'Zipkin' publisher for the input 'Settings'.
+new :: MonadIO m => Settings -> m Zipkin
+new (Settings mbMgr host port mbEpt prd) = liftIO $ do
+  mgr <- maybe (HTTP.newManager HTTP.defaultManagerSettings) pure mbMgr
+  tracer <- newTracer
+  let
+    req = HTTP.defaultRequest
+      { HTTP.method = "POST"
+      , HTTP.host = host
+      , HTTP.path = "/api/v2/spans"
+      , HTTP.port = port }
+  void $ if prd <= 0
+    then pure Nothing
+    else fmap Just $ forkIO $ forever $ do
+      threadDelay (microSeconds prd)
+      flushSpans mbEpt tracer req mgr -- Manager is thread-safe.
+  pure $ Zipkin mgr req tracer mbEpt
+
+-- | Runs a 'TraceT' action, sampling spans appropriately. Note that this method does not publish
+-- spans on its own; to do so, either call 'publish' manually or specify a positive
+-- 'settingsPublishPeriod' to publish in the background.
+run :: Zipkin -> TraceT m a -> m a
+run zipkin actn = runTraceT actn (zipkinTracer zipkin)
+
+-- | Flushes all complete spans to the Zipkin server. This method is thread-safe.
+publish :: MonadIO m => Zipkin -> m ()
+publish z =
+  liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z)
+
+-- | Adds a tag to the active span.
+tag :: MonadTrace m => Text -> Text -> m ()
+tag key val = addSpanEntry (publicKeyPrefix <> key) (tagTextValue val)
+
+-- | Annotates the active span using the current time.
+annotate :: MonadTrace m => Text -> m ()
+annotate val = addSpanEntry "" (logValue val)
+
+-- | Annotates the active span at the given time.
+annotateAt :: MonadTrace m => POSIXTime -> Text -> m ()
+annotateAt time val = addSpanEntry "" (logValueAt time val)
+
+-- | Exportable trace information, used for cross-process traces.
+data B3 = B3
+  { b3TraceID :: !TraceID
+  , b3SpanID :: !SpanID
+  , b3ParentSpanID :: !(Maybe SpanID)
+  , b3Sampling :: !(Maybe Sampling)
+  } deriving (Eq, Show)
+
+b3FromSpan :: Span -> B3
+b3FromSpan s =
+  let
+    ctx = spanContext s
+    samplingState = if fromMaybe False (lookupBoolBaggage debugKey ctx)
+      then Just Debug
+      else explicitSamplingState <$> lookupBoolBaggage samplingKey ctx
+  in B3 (contextTraceID ctx) (contextSpanID ctx) (parentID $ spanReferences s) samplingState
+
+-- Builder endos
+
+insertBaggage :: Key -> ByteString -> Endo Builder
+insertBaggage key val =
+  Endo $ \bldr -> bldr { builderBaggages = Map.insert key val (builderBaggages bldr) }
+
+insertTag :: JSON.ToJSON a => Key -> a -> Endo Builder
+insertTag key val =
+  Endo $ \bldr -> bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) }
+
+importB3 :: B3 -> Endo Builder
+importB3 b3 =
+  let
+    baggages = Map.fromList $ case b3Sampling b3 of
+      Just Accept -> [(samplingKey, "1")]
+      Just Deny -> [(samplingKey, "0")]
+      Just Debug -> [(debugKey, "1")]
+      Nothing -> []
+  in Endo $ \bldr -> bldr
+    { builderTraceID = Just (b3TraceID b3)
+    , builderSpanID = Just (b3SpanID b3)
+    , builderBaggages = baggages }
+
+-- | The sampling applied to a trace.
+--
+-- Note that non-sampled traces still yield active spans. However these spans are not published to
+-- Zipkin.
+data Sampling
+  = Accept
+  -- ^ Sample it.
+  | Debug
+  -- ^ Sample it and mark it as debug.
+  | Deny
+  -- ^ Do not sample it.
+  deriving (Eq, Ord, Enum, Show)
+
+applySampling :: Sampling -> Endo Builder
+applySampling Accept = insertBaggage samplingKey "1"
+applySampling Debug = insertBaggage debugKey "1"
+applySampling Deny = insertBaggage samplingKey "0"
+
+isSampled :: Span -> Bool
+isSampled spn =
+  let ctx = spanContext spn
+  in fromMaybe False $ lookupBoolBaggage debugKey ctx <|> lookupBoolBaggage samplingKey ctx
+
+publicKeyPrefix :: Text
+publicKeyPrefix = "Z."
+
+-- Debug baggage key.
+debugKey :: Key
+debugKey = "z.d"
+
+-- Sampling baggage key.
+samplingKey :: Key
+samplingKey = "z.s"
+
+-- Remote endpoint tag key.
+endpointKey :: Key
+endpointKey = "z.e"
+
+-- Kind tag key.
+kindKey :: Key
+kindKey = "z.k"
+
+-- Internal keys
+
+-- | Starts a new trace.
+rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a
+rootSpan sampling name = trace $ appEndo (applySampling sampling) $ builder name
+
+childSpan :: MonadTrace m => Endo Builder -> Name -> m a -> m a
+childSpan endo name actn = activeSpan >>= \case
+  Nothing -> actn
+  Just spn -> do
+    let
+      ctx = spanContext spn
+      bldr = (builder name)
+        { builderTraceID = Just $ contextTraceID ctx
+        , builderReferences = Set.singleton (ChildOf $ contextSpanID ctx) }
+    trace (appEndo endo $ bldr) actn
+
+-- | Continues an existing trace if present, otherwise does nothing.
+localSpan :: MonadTrace m => Name -> m a -> m a
+localSpan = childSpan mempty
+
+outgoingSpan :: MonadTrace m => Text -> Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a
+outgoingSpan kind mbEpt name f = childSpan endo name actn where
+  endo = insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt
+  actn = activeSpan >>= \case
+    Nothing -> f Nothing
+    Just spn -> f $ Just $ b3FromSpan spn
+
+clientSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a
+clientSpan = outgoingSpan "CLIENT"
+
+producerSpan :: MonadTrace m => Maybe Endpoint -> Name -> (Maybe B3 -> m a) -> m a
+producerSpan = outgoingSpan "PRODUCER"
+
+incomingSpan :: MonadTrace m => Text -> Maybe Endpoint -> B3 -> m a -> m a
+incomingSpan kind mbEpt b3 actn =
+  let
+    endo = importB3 b3 <> insertTag kindKey kind <> maybe mempty (insertTag endpointKey) mbEpt
+    bldr = appEndo endo $ builder ""
+  in trace bldr actn
+
+serverSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a
+serverSpan = incomingSpan "SERVER"
+
+consumerSpan :: MonadTrace m => Maybe Endpoint -> B3 -> m a -> m a
+consumerSpan = incomingSpan "CONSUMER"
+
+-- | Information about a hosted service.
+data Endpoint = Endpoint
+  { endpointService :: !(Maybe Text)
+  , endpointPort :: !(Maybe Int)
+  , endpointIPv4 :: !(Maybe IPv4)
+  , endpointIPv6 :: !(Maybe IPv6)
+  } deriving (Eq, Ord, Show)
+
+-- | An empty endpoint.
+defaultEndpoint :: Endpoint
+defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing
+
+instance JSON.ToJSON Endpoint where
+  toJSON (Endpoint mbSvc mbPort mbIPv4 mbIPv6) = JSON.object $ catMaybes
+    [ ("serviceName" JSON..=) <$> mbSvc
+    , ("port" JSON..=) <$> mbPort
+    , ("ipv4" JSON..=) <$> mbIPv4
+    , ("ipv6" JSON..=) <$> mbIPv6 ]
+
+explicitSamplingState :: Bool -> Sampling
+explicitSamplingState True = Accept
+explicitSamplingState False = Deny
+
+lookupBoolBaggage :: Key -> Context -> Maybe Bool
+lookupBoolBaggage key ctx = Map.lookup key (contextBaggages ctx) >>= \case
+  "0" -> Just False
+  "1" -> Just True
+  _ -> Nothing
+
+parentID :: Set Reference -> Maybe SpanID
+parentID = listToMaybe . catMaybes . fmap go . toList where
+  go (ChildOf d) = Just d
+  go _ = Nothing
+
+traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: Text
+traceIDHeader = "X-B3-TraceId"
+spanIDHeader = "X-B3-SpanId"
+parentSpanIDHeader = "X-B3-ParentSpanId"
+sampledHeader = "X-B3-Sampled"
+debugHeader = "X-B3-Flags"
+
+instance JSON.FromJSON B3 where
+  parseJSON = JSON.withObject "B3" $ \v -> do
+    dbg <- v JSON..:! debugHeader JSON..!= False
+    state <- fmap explicitSamplingState <$> v JSON..:! sampledHeader
+    let
+      sampling = case (dbg, state) of
+        (False, s) -> pure s
+        (True, Nothing) -> pure (Just Debug)
+        _ -> fail "bad debug and sampling combination"
+    B3
+      <$> v JSON..: traceIDHeader
+      <*> v JSON..: spanIDHeader
+      <*> v JSON..:! parentSpanIDHeader
+      <*> sampling
+
+instance JSON.ToJSON B3 where
+  toJSON (B3 traceID spanID mbParentID state) =
+    let
+      defaultKVs = [traceIDHeader JSON..= traceID, spanIDHeader JSON..= spanID]
+      parentKVs = (parentSpanIDHeader JSON..=) <$> maybeToList mbParentID
+      sampledKVs = case state of
+        Nothing -> []
+        Just Debug -> [debugHeader JSON..= ("1" :: Text)]
+        Just Accept -> [sampledHeader JSON..= ("1" :: Text)]
+        Just Deny -> [sampledHeader JSON..= ("0" :: Text)]
+    in JSON.object $ defaultKVs ++ parentKVs ++ sampledKVs
+
+data ZipkinAnnotation = ZipkinAnnotation !POSIXTime !JSON.Value
+
+instance JSON.ToJSON ZipkinAnnotation where
+  toJSON (ZipkinAnnotation t v) = JSON.object
+    [ "timestamp" JSON..= microSeconds @Int64 t
+    , "value" JSON..= v ]
+
+-- Internal type used to encode spans in the <https://zipkin.apache.org/zipkin-api/#/ format>
+-- expected by Zipkin.
+data ZipkinSpan = ZipkinSpan !(Maybe Endpoint) !Span !Tags !Logs !Interval
+
+publicTags :: Tags -> Map Text JSON.Value
+publicTags = Map.fromList . catMaybes . fmap go . Map.assocs where
+  go (k, v) = case T.stripPrefix publicKeyPrefix k of
+    Nothing -> Nothing
+    Just k' -> Just (k', v)
+
+instance JSON.ToJSON ZipkinSpan where
+  toJSON (ZipkinSpan mbEpt spn tags logs itv) =
+    let
+      ctx = spanContext spn
+      requiredKVs =
+        [ "traceId" JSON..= contextTraceID ctx
+        , "name" JSON..= spanName spn
+        , "id" JSON..= contextSpanID ctx
+        , "timestamp" JSON..= microSeconds @Int64 (intervalStart itv)
+        , "duration" JSON..= microSeconds @Int64 (intervalDuration itv)
+        , "debug" JSON..= fromMaybe False (lookupBoolBaggage debugKey ctx)
+        , "tags" JSON..= publicTags tags
+        , "annotations" JSON..= fmap (\(t, _, v) -> ZipkinAnnotation t v) logs ]
+      optionalKVs = catMaybes
+        [ ("parentId" JSON..=) <$> parentID (spanReferences spn)
+        , ("localEndpoint" JSON..=) <$> mbEpt
+        , ("remoteEndpoint" JSON..=) <$> Map.lookup endpointKey tags
+        , ("kind" JSON..=) <$> Map.lookup kindKey tags ]
+    in JSON.object $ requiredKVs ++ optionalKVs
+
+microSeconds :: Integral a => NominalDiffTime -> a
+microSeconds = round . (* 1000000)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+import Control.Monad.Trace
+import Control.Monad.Trace.Class
+import Monitor.Tracing
+
+import Control.Concurrent
+import Control.Concurrent.STM (atomically, tryReadTChan)
+import Control.Monad.Fix (fix)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT)
+import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get)
+import Data.IORef
+import Data.Text (Text)
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import UnliftIO (MonadUnliftIO)
+
+collectSpans :: MonadUnliftIO m => TraceT m () -> m [Span]
+collectSpans actn = do
+  tracer <- newTracer
+  runTraceT actn tracer
+  ref <- liftIO $ newIORef []
+  liftIO $ fix $ \loop -> atomically (tryReadTChan $ tracerChannel tracer) >>= \case
+    Nothing -> pure ()
+    Just (spn, _, _, _) -> modifyIORef ref (spn:) >> loop
+  reverse <$> liftIO (readIORef ref)
+
+main :: IO ()
+main = hspec $ do
+  describe "MonadTrace" $ do
+    it "should be instantiable with identity-based monads" $ do
+      let
+        actn :: (MonadReader Int m , MonadState Int m, MonadTrace m) => m Int
+        actn = trace "one" $ do
+          s <- get
+          r <- trace "two" ask
+          pure $ s + r
+        v = runReader (evalStateT actn 1) 2
+      v `shouldBe` 3
+  describe "trace" $ do
+    it "should not create spans when no traces are started" $ do
+      spans <- collectSpans @IO (pure ())
+      fmap spanName spans `shouldBe` []
+    it "should collect a single span when no children are created" $ do
+      spans <- collectSpans @IO (trace "t0" $ pure ())
+      fmap spanName spans `shouldBe` ["t0"]
+    it "should be able to stack on top of a ReaderT" $ do
+      spans <- (collectSpans @IO) $ trace "c2" $ pure ()
+      let
+        actn = trace "t" $ do
+          name <- ask
+          trace (builder name) $ pure ()
+      spans <- runReaderT (collectSpans @(ReaderT Text IO) actn) "foo"
+      fmap spanName spans `shouldBe` ["foo", "t"]
diff --git a/tracing.cabal b/tracing.cabal
new file mode 100644
--- /dev/null
+++ b/tracing.cabal
@@ -0,0 +1,68 @@
+name:                tracing
+version:             0.0.1.0
+synopsis:            Distributed tracing
+description:         https://github.com/mtth/tracing
+homepage:            https://github.com/mtth/tracing
+license:             BSD3
+license-file:        LICENSE
+author:              Matthieu Monsch
+maintainer:          matthieu.monsch@gmail.com
+copyright:           2019 Matthieu Monsch
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Control.Monad.Trace
+                     , Control.Monad.Trace.Class
+                     , Monitor.Tracing
+                     , Monitor.Tracing.Jaeger
+                     , Monitor.Tracing.Zipkin
+  other-modules:       Control.Monad.Trace.Internal
+  build-depends:       aeson >= 1.4 && < 1.5
+                     , base >= 4.8 && < 5
+                     , base16-bytestring >= 0.1 && < 0.2
+                     , bytestring >= 0.10 && < 0.11
+                     , containers >= 0.6 && < 0.7
+                     , http-client >= 0.5 && < 0.6
+                     , ip >= 1.4 && < 1.5
+                     , mtl >= 2.2 && < 2.3
+                     , random >= 1.1 && < 1.2
+                     , stm >= 2.5 && < 2.6
+                     , text >= 1.2 && < 1.3
+                     , time >= 1.8 && < 1.9
+                     , transformers >= 0.5 && < 0.6
+                     , unliftio >= 0.2 && < 0.3
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+test-suite tracing-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs:
+      test
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base >=4.8 && <5
+                     , hspec >=2.6 && <2.7
+                     , mtl >= 2.2 && < 2.3
+                     , stm >= 2.5 && < 2.6
+                     , text >= 1.2 && < 1.3
+                     , tracing
+                     , unliftio >= 0.2 && < 0.3
+  default-language: Haskell2010
+
+executable zipkin-example
+  hs-source-dirs:      app
+  main-is:             ZipkinExample.hs
+  build-depends:       aeson >= 1.4 && < 1.5
+                     , base >=4.8 && <5
+                     , bytestring >= 0.10 && < 0.11
+                     , containers >= 0.6 && < 0.7
+                     , ip >= 1.4 && < 1.5
+                     , stm >= 2.5 && < 2.6
+                     , text >= 1.2 && < 1.3
+                     , tracing
+                     , unliftio >= 0.2 && < 0.3
+  default-language:    Haskell2010