diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Matthieu Monsch (c) 2019-2020
+
+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,25 @@
+# Tracing [![Hackage](https://img.shields.io/hackage/v/tracing-control.svg)](https://hackage.haskell.org/package/tracing-control)
+
+**Important note**: this is a fork of the original [tracing](https://github.com/mtth/tracing) library in which `unliftio` has been replaced by `monad-control`.
+
+An [OpenTracing](https://opentracing.io/)-compliant, simple, and extensible
+distributed tracing library.
+
++ _Simple:_ add a single `MonadTrace` constraint to start tracing, without
+  making your code harder to test!
++ _Extensible:_ use the built-in [Zipkin](http://zipkin.io) backend or hook in
+  your own trace publication logic.
+
+```haskell
+import Monitor.Tracing
+
+-- A traced action with its root span and two children.
+run :: MonadTrace m => m ()
+run = rootSpan alwaysSampled "parent" $ do
+  childSpan "child-a" runA
+  childSpan "child-b" runB
+```
+
+To learn more, hop on over to
+[`Monitor.Tracing`](https://hackage.haskell.org/package/tracing/docs/Monitor-Tracing.html),
+or take a look at examples in the `examples/` folder.
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/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,195 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}         -- For the MonadBaseControl instance.
+{-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.
+
+-- | This module is useful mostly for tracing backend implementors. If you are only interested in
+-- adding tracing to an application, start at "Monitor.Tracing".
+module Control.Monad.Trace (
+  -- * Tracers
+  Tracer, newTracer,
+  runTraceT, TraceT(..),
+
+  -- * Collected data
+  -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note
+  -- that only sampled spans are eligible: spans which are 'Control.Monad.Trace.Class.neverSampled'
+  -- appear in neither.
+
+  -- ** Completed spans
+  spanSamples, Sample(..), Tags, Logs,
+
+  -- ** Pending spans
+  pendingSpanCount,
+) where
+
+import Prelude hiding (span)
+
+import Control.Monad.Trace.Class
+import Control.Monad.Trace.Internal
+
+import Control.Applicative ((<|>))
+import Control.Concurrent.STM.Lifted (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)
+import Control.Exception.Lifted (finally)
+import Control.Monad.Base (MonadBase, liftBase)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)
+import Control.Monad.Reader.Class (MonadReader)
+import Control.Monad.Error.Class (MonadError)
+import Control.Monad.State.Class (MonadState)
+import Control.Monad.Trans.Class (MonadTrans, lift)
+import Control.Monad.Trans.Control (MonadBaseControl(..), RunInBase)
+import Control.Monad.Writer.Class (MonadWriter)
+import qualified Data.Aeson as JSON
+import Data.Coerce
+import Data.Foldable (for_)
+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)
+
+-- | A collection of span tags.
+type Tags = Map Key JSON.Value
+
+-- | A collection of span logs.
+type Logs = [(POSIXTime, Key, JSON.Value)]
+
+-- | A sampled span and its associated metadata.
+data Sample = Sample
+  { sampleSpan :: !Span
+  -- ^ The sampled span.
+  , sampleTags :: !Tags
+  -- ^ Tags collected during this span.
+  , sampleLogs :: !Logs
+  -- ^ Logs collected during this span, sorted in chronological order.
+  , sampleStart :: !POSIXTime
+  -- ^ The time the span started at.
+  , sampleDuration :: !NominalDiffTime
+  -- ^ The span's duration.
+  }
+
+-- | A tracer is a producer of spans.
+--
+-- More specifically, a tracer:
+--
+-- * runs 'MonadTrace' actions via 'runTraceT',
+-- * transparently collects their generated spans,
+-- * and outputs them to a channel (available via 'spanSamples').
+--
+-- These samples can then be consumed independently, decoupling downstream span processing from
+-- their production.
+data Tracer = Tracer
+  { tracerChannel :: TChan Sample
+  , tracerPendingCount :: TVar Int
+  }
+
+-- | Creates a new 'Tracer'.
+newTracer :: MonadIO m => m Tracer
+newTracer = liftIO $ Tracer <$> newTChanIO <*> newTVarIO 0
+
+-- | Returns the number of spans currently in flight (started but not yet completed).
+pendingSpanCount :: Tracer -> TVar Int
+pendingSpanCount = tracerPendingCount
+
+-- | Returns all newly completed spans' samples. The samples become available in the same order they
+-- are completed.
+spanSamples :: Tracer -> TChan Sample
+spanSamples = tracerChannel
+
+data Scope = Scope
+  { scopeTracer :: !Tracer
+  , scopeSpan :: !(Maybe Span)
+  , scopeTags :: !(Maybe (TVar Tags))
+  , scopeLogs :: !(Maybe (TVar Logs))
+  }
+
+-- | A span generation monad.
+newtype TraceT m a = TraceT { traceTReader :: ReaderT Scope m a }
+  deriving ( Functor, Applicative, Monad, MonadTrans
+           , MonadWriter w, MonadState s, MonadError e
+           , MonadIO, MonadBase b )
+
+instance MonadReader r m => MonadReader r (TraceT m) where
+  ask = lift ask
+  local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r
+
+-- Cannot be derived in GHC 8.0 due to type family.
+instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where
+  type StM (TraceT m) a = StM (ReaderT Scope m) a
+  liftBaseWith :: forall a. (RunInBase (TraceT m) b -> b a) -> TraceT m a
+  liftBaseWith
+    = coerce @((RunInBase (ReaderT Scope m) b -> b a) -> ReaderT Scope m a)
+             liftBaseWith
+  restoreM :: forall a. StM (TraceT m) a -> TraceT m a
+  restoreM
+    = coerce @(StM (ReaderT Scope m) a -> ReaderT Scope m a)
+             restoreM
+
+instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where
+  trace bldr (TraceT reader) = TraceT $ do
+    parentScope <- ask
+    let
+      mbParentSpn = scopeSpan parentScope
+      mbParentCtx = spanContext <$> mbParentSpn
+      mbTraceID = contextTraceID <$> mbParentCtx
+    spanID <- maybe (liftBase randomSpanID) pure $ builderSpanID bldr
+    traceID <- maybe (liftBase randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
+    sampling <- case builderSamplingPolicy bldr of
+      Just policy -> liftIO policy
+      Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn)
+    let
+      baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx
+      ctx = Context traceID spanID (builderBaggages bldr `Map.union` baggages)
+      spn = Span (builderName bldr) ctx (builderReferences bldr) sampling
+      tracer = scopeTracer parentScope
+    if spanIsSampled spn
+      then do
+        tagsTV <- newTVarIO $ builderTags bldr
+        logsTV <- newTVarIO []
+        startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.
+        let
+          run = do
+            start <- liftIO $ getPOSIXTime
+            atomically $ do
+              writeTVar startTV (Just start)
+              modifyTVar' (tracerPendingCount tracer) (+1)
+            local (const $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader
+          cleanup = do
+            end <- liftIO $ getPOSIXTime
+            atomically $ readTVar startTV >>= \case
+              Nothing -> pure () -- The action was interrupted before the span was pending.
+              Just start -> do
+                modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)
+                tags <- readTVar tagsTV
+                logs <- sortOn (\(t, k, _) -> (t, k)) <$> readTVar logsTV
+                writeTChan (tracerChannel tracer) (Sample spn tags logs start (end - start))
+        run `finally` cleanup
+      else local (const $ Scope tracer (Just spn) Nothing Nothing) reader
+
+  activeSpan = TraceT $ asks scopeSpan
+
+  addSpanEntry key (TagValue val) = TraceT $ do
+    mbTV <- asks scopeTags
+    for_ mbTV $ \tv -> atomically $ modifyTVar' tv $ Map.insert key val
+  addSpanEntry key (LogValue val mbTime)  = TraceT $ do
+    mbTV <- asks scopeLogs
+    for_ mbTV $ \tv -> do
+      time <- maybe (liftIO getPOSIXTime) pure mbTime
+      atomically $ modifyTVar' tv ((time, key, val) :)
+
+-- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to
+-- trace multiple actions concurrently.
+--
+-- Unless you are implementing a custom span publication backend, you should not need to call this
+-- method explicitly. Instead, prefer to use the backend's functionality directly (e.g.
+-- 'Monitor.Tracing.Zipkin.run' for Zipkin). To ease debugging in certain cases,
+-- 'Monitor.Tracing.Local.collectSpanSamples' is also available.
+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,222 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | This module exposes the generic 'MonadTrace' class.
+module Control.Monad.Trace.Class (
+  -- * Types
+  Span(..), spanIsSampled, spanIsDebug,
+  Context(..),
+  TraceID(..), decodeTraceID, encodeTraceID,
+  SpanID(..), decodeSpanID, encodeSpanID,
+  Reference(..),
+
+  -- * Generating traces
+  -- ** Individual spans
+  MonadTrace(..),
+  Builder(..), Name, builder,
+  -- ** Structured traces
+  rootSpan, rootSpanWith, childSpan, childSpanWith,
+  -- ** Sampling
+  SamplingDecision(..),
+  SamplingPolicy, alwaysSampled, neverSampled, sampledWithProbability, sampledWhen, debugEnabled,
+
+  -- * Annotating traces
+  -- | Note that not all annotation types are supported by all backends. For example Zipkin only
+  -- supports string tags (refer to "Monitor.Tracing.Zipkin" for the full list of supported span
+  -- metadata).
+  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)
+import System.Random (randomRIO)
+
+-- | A monad capable of generating and modifying trace spans.
+--
+-- This package currently provides two instances of this class:
+--
+-- * '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. If the action isn't currently being traced,
+  -- 'trace' should be a no-op. Otherwise, the new span should share the active span's trace ID,
+  -- sampling decision, and baggages unless overridden by the input 'Builder'.
+  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 MonadTrace m => MonadTrace (ExceptT e m) where
+  trace name (ExceptT actn) = ExceptT $ trace name actn
+
+instance MonadTrace m => MonadTrace (ReaderT r m) where
+  trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)
+
+instance (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 (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 MonadTrace m => MonadTrace (State.Lazy.StateT s m) where
+  trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)
+
+instance MonadTrace m => MonadTrace (State.Strict.StateT s m) where
+  trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)
+
+instance (MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where
+  trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn
+
+instance (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 span builder.
+--
+-- '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.
+  , builderSamplingPolicy :: !(Maybe SamplingPolicy)
+  -- ^ How the span should be sampled. If unset, the active's span sampling will be used if present,
+  -- otherwise the span will not be sampled.
+  }
+
+-- | 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 Nothing
+
+instance IsString Builder where
+  fromString = builder . T.pack
+
+-- | An action to determine how a span should be sampled.
+type SamplingPolicy = IO SamplingDecision
+
+-- | Returns a 'SamplingPolicy' which always samples.
+alwaysSampled :: SamplingPolicy
+alwaysSampled = pure Always
+
+-- | Returns a 'SamplingPolicy' which never samples.
+neverSampled :: SamplingPolicy
+neverSampled = pure Never
+
+-- | Returns a debug 'SamplingPolicy'. Debug spans are always sampled.
+debugEnabled :: SamplingPolicy
+debugEnabled = pure Debug
+
+-- | Returns a 'SamplingPolicy' which samples a span iff the input is 'True'. It is equivalent to:
+--
+-- > sampledWhen b = if b then alwaysSampled else neverSampled
+sampledWhen :: Bool -> SamplingPolicy
+sampledWhen b = pure $ if b then Always else Never
+
+-- | Returns a 'SamplingPolicy' which randomly samples spans.
+sampledWithProbability :: Double -> SamplingPolicy
+sampledWithProbability r = randomRIO (0, 1) >>= sampledWhen . (< r)
+
+-- Generic span creation
+
+-- | Starts a new trace, customizing the span builder. Note that the sampling input will override
+-- any sampling customization set on the builder.
+rootSpanWith :: MonadTrace m => (Builder -> Builder) -> SamplingPolicy -> Name -> m a -> m a
+rootSpanWith f policy name = trace $ (f $ builder name) { builderSamplingPolicy = Just policy }
+
+-- | Starts a new trace. For performance reasons, it is possible to customize how frequently tracing
+-- information is collected. This allows fine-grain control on the overhead induced by tracing. For
+-- example, you might only want to sample 1% of a very actively used call-path with
+-- @sampledWithProbability 0.01@.
+rootSpan :: MonadTrace m => SamplingPolicy -> Name -> m a -> m a
+rootSpan = rootSpanWith id
+
+-- | Extends a trace, same as 'childSpan' but also customizing the builder.
+childSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> m a -> m a
+childSpanWith f name actn = activeSpan >>= \case
+  Nothing -> actn
+  Just spn -> do
+    let
+      ctx = spanContext spn
+      bldr = f $ builder name
+      bldr' = bldr
+        { builderTraceID = Just $ contextTraceID ctx
+        , builderReferences = Set.insert (ChildOf $ contextSpanID ctx) (builderReferences bldr) }
+    trace bldr' actn
+
+-- | Extends a trace: the active span's ID will be added as a reference to a newly created span and
+-- both spans will share the same trace ID. If no span is active, 'childSpan' is a no-op.
+childSpan :: MonadTrace m => Name -> m a -> m a
+childSpan = childSpanWith id
+
+-- 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,139 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Control.Monad.Trace.Internal (
+  TraceID(..), encodeTraceID, decodeTraceID, randomTraceID,
+  SpanID(..), encodeSpanID, decodeSpanID, randomSpanID,
+  Context(..),
+  Name,
+  Span(..),
+  SamplingDecision(..), spanIsSampled, spanIsDebug,
+  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)
+
+-- | Hex-encodes a trace ID.
+encodeTraceID :: TraceID -> Text
+encodeTraceID (TraceID bs) = hexEncode bs
+
+-- | Decodes a traced ID from a hex-encoded string.
+decodeTraceID :: Text -> Maybe TraceID
+decodeTraceID txt = case hexDecode txt of
+  Just bs | BS.length bs == 16 -> Just $ TraceID bs
+  _ -> Nothing
+
+instance JSON.FromJSON TraceID where
+  parseJSON = JSON.withText "TraceID" $ maybe (fail "invalid hex-encoding") pure . decodeTraceID
+
+instance JSON.ToJSON TraceID where
+  toJSON = JSON.toJSON . encodeTraceID
+
+-- | 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)
+
+-- | Hex-encodes a span ID.
+encodeSpanID :: SpanID -> Text
+encodeSpanID (SpanID bs) = hexEncode bs
+
+-- | Decodes a span ID from a hex-encoded string.
+decodeSpanID :: Text -> Maybe SpanID
+decodeSpanID txt = case hexDecode txt of
+  Just bs | BS.length bs == 8 -> Just $ SpanID bs
+  _ -> Nothing
+
+instance JSON.FromJSON SpanID where
+  parseJSON = JSON.withText "SpanID" $ maybe (fail "invalid hex-encoding") pure . decodeSpanID
+
+instance JSON.ToJSON SpanID where
+  toJSON = JSON.toJSON . encodeSpanID
+
+-- | 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.
+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)
+  , spanSamplingDecision :: !SamplingDecision
+  }
+
+-- | A span's sampling decision.
+data SamplingDecision
+  = Always
+  | Never
+  | Debug
+  deriving (Eq, Ord, Enum, Show)
+
+-- | Returns whether the span is sampled.
+spanIsSampled :: Span -> Bool
+spanIsSampled spn = spanSamplingDecision spn /= Never
+
+-- | Returns whether the span has debug enabled.
+spanIsDebug :: Span -> Bool
+spanIsDebug spn = spanSamplingDecision spn == Debug
+
+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,59 @@
+-- | This module is where you should start if you are interested in adding tracing to an
+-- application. It provides backend-agnostic utilities to generate traces. Trace publication and
+-- other backend-specific features are available in the modules below @Monitor.Tracing@ (e.g.
+-- "Monitor.Tracing.Zipkin"). The additional functionality exposed under @Control.Monad@ in this
+-- package is useful if you wish to implement a new tracing backend.
+module Monitor.Tracing (
+  -- * Overview
+  -- | Let's assume we are interested in tracing the two following functions:
+  --
+  -- > 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 'childSpan' calls and adding a 'MonadTrace'
+  -- constraint:
+  --
+  -- > import Monitor.Tracing
+  -- >
+  -- > listTaskIDs :: (MonadIO m, MonadTrace m) => m [Int]
+  -- > listTaskIDs = childSpan "list-task-ids" listTaskIDs'
+  -- >
+  -- > fetchTasks :: (MonadIO m, MonadTrace m) => [Int] -> m [Task]
+  -- > fetchTasks = childSpan "fetch-tasks" . fetchTasks'
+  --
+  -- Spans will now automatically get generated any time these actions are run! Each span will be
+  -- associated with various useful pieces of metadata, including lineage. For example, if we wrap
+  -- the two above functions in a 'rootSpan', the spans will correctly be nested:
+  --
+  -- > printTasks :: (MonadIO m, MonadTrace m) => m ()
+  -- > printTasks = rootSpan alwaysSampled "list-tasks" $ listTaskIDs >>= fetchTasks >>= print
+  --
+  -- Spans can then be published to various backends. For example, to run the above action and
+  -- publish its spans using Zipkin:
+  --
+  -- > import qualified Monitor.Tracing.Zipkin as ZPK
+  -- >
+  -- > main :: IO ()
+  -- > main = ZPK.with ZPK.defaultSettings $ ZPK.run printTasks
+
+  -- * Trace creation
+  MonadTrace,
+
+  -- ** Starting a new trace
+  -- | By default, traces created by 'trace' are independent from each other. However, we can get a
+  -- lot more value out of tracing by organizing a trace's spans. The simplest and most common
+  -- approach is to build a tree of spans, with a single root span and zero or more children for
+  -- each span. 'rootSpan' and 'childSpan' below set up spans such that lineage information is
+  -- automatically propagated.
+  rootSpan, alwaysSampled, neverSampled, sampledWhen, sampledWithProbability, debugEnabled,
+
+  -- ** Extending a trace
+  childSpan,
+
+  -- * Backends
+  -- | As a convenience, the top-level type for each backend is exported here.
+  Zipkin
+) where
+
+import Control.Monad.Trace.Class
+import Monitor.Tracing.Zipkin (Zipkin)
diff --git a/src/Monitor/Tracing/Local.hs b/src/Monitor/Tracing/Local.hs
new file mode 100644
--- /dev/null
+++ b/src/Monitor/Tracing/Local.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleContexts #-}
+-- | This module provides convenience functionality to debug traces locally. For production use,
+-- prefer alternatives, e.g. "Monitor.Tracing.Zipkin".
+module Monitor.Tracing.Local (
+  collectSpanSamples
+) where
+
+import Control.Concurrent.STM (atomically, readTVar, readTChan, tryReadTChan)
+import Control.Monad.Fix (fix)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trace
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Data.IORef (modifyIORef', newIORef, readIORef)
+
+-- | Runs a 'TraceT' action, returning any collected samples alongside its output. The samples are
+-- sorted chronologically by completion time (e.g. the head is the first span to complete).
+--
+-- Spans which start before the action returns are guaranteed to be collected, even if they complete
+-- after (in this case collection will block until their completion). More precisely,
+-- 'collectSpanSamples' will return the first time there are no pending spans after the action is
+-- done. For example:
+--
+-- > collectSpanSamples $ rootSpan alwaysSampled "parent" $ do
+-- >   forkIO $ childSpan "child" $ threadDelay 2000000 -- Asynchronous 2 second child span.
+-- >   threadDelay 1000000 -- Returns after one second, but the child span will still be sampled.
+collectSpanSamples :: (MonadIO m, MonadBaseControl IO m)
+                   => TraceT m a -> m (a, [Sample])
+collectSpanSamples actn = do
+  tracer <- newTracer
+  rv <- runTraceT actn tracer
+  ref <- liftIO $ newIORef []
+  let
+    addSample spl = liftIO $ modifyIORef' ref (spl:)
+    samplesTC = spanSamples tracer
+    pendingTV = pendingSpanCount tracer
+  liftIO $ fix $ \loop -> do
+    (mbSample, pending) <- atomically $ (,) <$> tryReadTChan samplesTC <*> readTVar pendingTV
+    case mbSample of
+      Just spl -> addSample spl >> loop
+      Nothing | pending > 0 -> liftIO (atomically $ readTChan samplesTC) >>= addSample >> loop
+      _ -> pure ()
+  spls <- reverse <$> liftIO (readIORef ref)
+  pure (rv, spls)
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,449 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | This module implements a <https://zipkin.apache.org/ Zipkin>-powered trace publisher. You will
+-- almost certainly want to import it qualified.
+--
+-- Zipkin does not support all OpenTracing functionality. To guarantee that everything works as
+-- expected, you should only use the functions defined in this module or exported by
+-- "Monitor.Tracing".
+module Monitor.Tracing.Zipkin (
+  -- * Configuration
+  -- ** General settings
+  Settings(..), defaultSettings,
+  -- ** Endpoint
+  Endpoint(..), defaultEndpoint,
+
+  -- * Publishing traces
+  Zipkin,
+  new, run, publish, with,
+
+  -- * Cross-process spans
+  -- ** Communication
+  B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue,
+  -- ** Span generation
+  clientSpan, clientSpanWith, serverSpan, serverSpanWith, producerSpanWith, consumerSpanWith,
+
+  -- * Custom metadata
+  -- ** Tags
+  tag, addTag, addInheritedTag,
+  -- ** Annotations
+  -- | Annotations are similar to tags, but timestamped.
+  annotate, annotateAt,
+  -- ** Endpoints
+  addEndpoint
+) where
+
+import Control.Monad.Trace
+import Control.Monad.Trace.Class
+
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.STM (atomically, tryReadTChan)
+import Control.Exception.Lifted (finally)
+import Control.Monad (forever, guard, void, when)
+import Control.Monad.Fix (fix)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import qualified Data.Aeson as JSON
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS
+import Data.CaseInsensitive (CI)
+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, maybeToList)
+import Data.Monoid (Endo(..))
+#if !MIN_VERSION_base(4, 11, 0)
+import Data.Semigroup ((<>))
+#endif
+import Data.Set (Set)
+import Data.String (IsString(..))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Time.Clock.POSIX (POSIXTime)
+import Network.HTTP.Client (Manager, Request)
+import qualified Network.HTTP.Client as HTTP
+import Network.Socket (HostName, PortNumber)
+
+-- | 'Zipkin' creation settings.
+data Settings = Settings
+  { settingsHostname :: !(Maybe HostName)
+  -- ^ The Zipkin server's hostname, defaults to @localhost@ if unset.
+  , settingsPort :: !(Maybe PortNumber)
+  -- ^ The port the Zipkin server is listening on, defaults to @9411@ if unset.
+  , settingsEndpoint :: !(Maybe Endpoint)
+  -- ^ Local endpoint included in all published spans.
+  , settingsManager :: !(Maybe Manager)
+  -- ^ An optional HTTP manager to use for publishing spans on the Zipkin server.
+  , settingsPublishPeriod :: !(Maybe NominalDiffTime)
+  -- ^ If set to a positive value, traces will be flushed in the background every such period.
+  }
+
+-- | Creates empty 'Settings'. You will typically use this (or the 'IsString' instance) as starting
+-- point to only fill in the fields you care about:
+--
+-- > let settings = defaultSettings { settingsPort = Just 2222 }
+defaultSettings :: Settings
+defaultSettings = Settings Nothing Nothing Nothing Nothing Nothing
+
+-- | Generates settings with the given string as hostname.
+instance IsString Settings where
+  fromString s = defaultSettings { settingsHostname = Just s }
+
+-- | A Zipkin trace publisher.
+--
+-- All publisher functionality is thread-safe. In particular it is safe to 'publish' concurrently
+-- with 'run', and/or 'run' multiple actions concurrently. Note also that all sampled spans are
+-- retained in memory until they are published.
+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 $ spanSamples tracer) >>= \case
+    Nothing -> pure ()
+    Just sample -> modifyIORef ref (ZipkinSpan ept sample:) >> loop
+  spns <- readIORef ref
+  when (not $ null spns) $ do
+    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 mbHostname mbPort mbEpt mbMgr mbPrd) = liftIO $ do
+  mgr <- maybe (HTTP.newManager HTTP.defaultManagerSettings) pure mbMgr
+  tracer <- newTracer
+  let
+    req = HTTP.defaultRequest
+      { HTTP.method = "POST"
+      , HTTP.host = BS.pack (fromMaybe "localhost" mbHostname)
+      , HTTP.requestHeaders = [("Content-Type", "application/json")]
+      , HTTP.path = "/api/v2/spans"
+      , HTTP.port = maybe 9411 fromIntegral mbPort }
+  void $ let prd = fromMaybe 0 mbPrd in 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 :: TraceT m a -> Zipkin -> m a
+run actn zipkin = runTraceT actn (zipkinTracer zipkin)
+
+-- | Flushes all complete spans to the Zipkin server.
+publish :: MonadIO m => Zipkin -> m ()
+publish z =
+  liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z)
+
+-- | Convenience method to start a 'Zipkin', run an action, and publish all spans before returning.
+with :: (MonadIO m, MonadBaseControl IO m)
+     => Settings -> (Zipkin -> m a) -> m a
+with settings f = do
+  zipkin <- new settings
+  f zipkin `finally` publish zipkin
+
+-- | Adds a tag to the active span.
+tag :: MonadTrace m => Text -> Text -> m ()
+tag key val = addSpanEntry (publicKeyPrefix <> key) (tagTextValue val)
+
+-- | Adds a tag to a builder. This is a convenience method to use with 'childSpanWith', for example:
+--
+-- > childSpanWith (addTag "key" "value") "run" $ action
+--
+-- Note that there is not difference with adding the tag after the span. So the above code is
+-- equivalent to:
+--
+-- > childSpan "run" $ tag "key" "value" >> action
+addTag :: Text -> Text -> Builder -> Builder
+addTag key val bldr = bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) }
+
+-- | Adds an inherited tag to a builder. Unlike a tag added via 'addTag', this tag:
+--
+-- * will be inherited by all the span's /local/ children.
+-- * can only be added at span construction time.
+--
+-- For example, to add an ID tag to all spans inside a trace:
+--
+-- > rootSpanWith (addInheritedTag "id" "abcd-efg") alwaysSampled "run" $ action
+addInheritedTag :: Text -> Text -> Builder -> Builder
+addInheritedTag key val bldr =
+  let bgs = builderBaggages bldr
+  in bldr { builderBaggages = Map.insert key (T.encodeUtf8 val) bgs }
+
+-- | 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
+  -- ^ The span's trace ID.
+  , b3SpanID :: !SpanID
+  -- ^ The span's ID.
+  , b3IsSampled :: !Bool
+  -- ^ Whether the span was sampled.
+  , b3IsDebug :: !Bool
+  -- ^ Whether the span has debug enabled (which implies that the span is sampled).
+  , b3ParentSpanID :: !(Maybe SpanID)
+  -- ^ The span's parent's ID, or 'Nothing' for root spans.
+  } deriving (Eq, Ord, Show)
+
+traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: CI ByteString
+traceIDHeader = "X-B3-TraceId"
+spanIDHeader = "X-B3-SpanId"
+parentSpanIDHeader = "X-B3-ParentSpanId"
+sampledHeader = "X-B3-Sampled"
+debugHeader = "X-B3-Flags"
+
+-- | Serializes the 'B3' to multiple headers, suitable for HTTP requests. All byte-strings are UTF-8
+-- encoded.
+b3ToHeaders :: B3 -> Map (CI ByteString) ByteString
+b3ToHeaders (B3 traceID spanID isSampled isDebug mbParentID) =
+  let
+    defaultKVs = [(traceIDHeader, encodeTraceID traceID), (spanIDHeader, encodeSpanID spanID)]
+    parentKVs = (parentSpanIDHeader,) . encodeSpanID <$> maybeToList mbParentID
+    sampledKVs = case (isSampled, isDebug) of
+      (_, True) -> [(debugHeader, "1")]
+      (True, _) -> [(sampledHeader, "1")]
+      (False, _) -> [(sampledHeader, "0")]
+  in fmap T.encodeUtf8 $ Map.fromList $ defaultKVs ++ parentKVs ++ sampledKVs
+
+-- | Deserializes the 'B3' from multiple headers.
+b3FromHeaders :: Map (CI ByteString) ByteString -> Maybe B3
+b3FromHeaders hdrs = do
+  let
+    find key = T.decodeUtf8 <$> Map.lookup key hdrs
+    findBool def key = case find key of
+      Nothing -> Just def
+      Just "1" -> Just True
+      Just "0" -> Just False
+      _ -> Nothing
+  dbg <- findBool False debugHeader
+  sampled <- findBool dbg sampledHeader
+  guard (not $ sampled == False && dbg)
+  B3
+    <$> (find traceIDHeader >>= decodeTraceID)
+    <*> (find spanIDHeader >>= decodeSpanID)
+    <*> pure sampled
+    <*> pure dbg
+    <*> maybe (pure Nothing) (Just <$> decodeSpanID) (find parentSpanIDHeader)
+
+-- | Serializes the 'B3' to a single UTF-8 encoded header value. It will typically be set as
+-- <https://github.com/apache/incubator-zipkin-b3-propagation#single-header b3 header>.
+b3ToHeaderValue :: B3 -> ByteString
+b3ToHeaderValue (B3 traceID spanID isSampled isDebug mbParentID) =
+  let
+    state = case (isSampled, isDebug) of
+      (_ , True) -> "d"
+      (True, _) -> "1"
+      (False, _) -> "0"
+    required = [encodeTraceID traceID, encodeSpanID spanID, state]
+    optional = encodeSpanID <$> maybeToList mbParentID
+  in BS.intercalate "-" $ fmap T.encodeUtf8 $ required ++ optional
+
+-- | Deserializes a single header value into a 'B3'.
+b3FromHeaderValue :: ByteString -> Maybe B3
+b3FromHeaderValue bs = case T.splitOn "-" $ T.decodeUtf8 bs of
+  (traceIDstr:spanIDstr:strs) -> do
+    traceID <- decodeTraceID traceIDstr
+    spanID <- decodeSpanID spanIDstr
+    let buildB3 = B3 traceID spanID
+    case strs of
+      [] -> pure $ buildB3 False False Nothing
+      (state:strs') -> do
+        buildB3' <- case state of
+          "0" -> pure $ buildB3 False False
+          "1" -> pure $ buildB3 True False
+          "d" -> pure $ buildB3 True True
+          _ -> Nothing
+        case strs' of
+          [] -> pure $ buildB3' Nothing
+          [str] -> buildB3' . Just <$> decodeSpanID str
+          _ -> Nothing
+  _ -> Nothing
+
+b3FromSpan :: Span -> B3
+b3FromSpan s =
+  let
+    ctx = spanContext s
+    refs = spanReferences s
+  in B3 (contextTraceID ctx) (contextSpanID ctx) (spanIsSampled s) (spanIsDebug s) (parentID refs)
+
+-- Builder endos
+
+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
+    policy = if b3IsDebug b3
+      then debugEnabled
+      else sampledWhen $ b3IsSampled b3
+  in Endo $ \bldr -> bldr
+    { builderTraceID = Just (b3TraceID b3)
+    , builderSpanID = Just (b3SpanID b3)
+    , builderSamplingPolicy = Just policy }
+
+publicKeyPrefix :: Text
+publicKeyPrefix = "Z."
+
+-- Remote endpoint tag key.
+endpointKey :: Key
+endpointKey = "z.e"
+
+-- Kind tag key.
+kindKey :: Key
+kindKey = "z.k"
+
+-- Internal keys
+
+outgoingSpan :: MonadTrace m => Text -> Endo Builder -> Name -> (Maybe B3 -> m a) -> m a
+outgoingSpan kind endo name f = childSpanWith (appEndo endo') name actn where
+  endo' = insertTag kindKey kind <> endo
+  actn = activeSpan >>= \case
+    Nothing -> f Nothing
+    Just spn -> f $ Just $ b3FromSpan spn
+
+-- | Generates a child span with @CLIENT@ kind. This function also provides the corresponding 'B3'
+-- (or 'Nothing' if tracing is inactive) so that it can be forwarded to the server. For example, to
+-- emit an HTTP request and forward the trace information in the headers:
+--
+-- > import Network.HTTP.Simple
+-- >
+-- > clientSpan "api-call" $ \(Just b3) -> $ do
+-- >   res <- httpBS "http://host/api" & addRequestHeader "b3" (b3ToHeaderValue b3)
+-- >   process res -- Do something with the response.
+clientSpan :: MonadTrace m => Name -> (Maybe B3 -> m a) -> m a
+clientSpan = clientSpanWith id
+
+-- | Generates a client span, optionally modifying the span's builder. This can be useful in
+-- combination with 'addEndpoint' if the remote server does not have tracing enabled.
+clientSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a
+clientSpanWith f = outgoingSpan "CLIENT" (Endo f)
+
+-- | Generates a child span with @PRODUCER@ kind. This function also provides the corresponding 'B3'
+-- so that it can be forwarded to the consumer.
+producerSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a
+producerSpanWith f = outgoingSpan "PRODUCER" (Endo f)
+
+incomingSpan :: MonadTrace m => Text -> Endo Builder -> B3 -> m a -> m a
+incomingSpan kind endo b3 actn =
+  let bldr = appEndo (importB3 b3 <> insertTag kindKey kind <> endo) $ builder ""
+  in trace bldr actn
+
+-- | Generates a child span with @SERVER@ kind. The client's 'B3' should be provided as input,
+-- for example parsed using 'b3FromHeaders'.
+serverSpan :: MonadTrace m => B3 -> m a -> m a
+serverSpan = serverSpanWith id
+
+-- | Generates a server span, optionally modifying the span's builder. This can be useful in
+-- combination with 'addEndpoint' if the remote client does not have tracing enabled.
+serverSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a
+serverSpanWith f = incomingSpan "SERVER" (Endo f)
+
+-- | Generates a child span with @CONSUMER@ kind. The producer's 'B3' should be provided as input.
+consumerSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a
+consumerSpanWith f = incomingSpan "CONSUMER" (Endo f)
+
+-- | Information about a hosted service, included in spans and visible in the Zipkin UI.
+data Endpoint = Endpoint
+  { endpointService :: !(Maybe Text)
+  -- ^ The endpoint's service name.
+  , endpointPort :: !(Maybe Int)
+  -- ^ The endpoint's port, if applicable and known.
+  , endpointIPv4 :: !(Maybe Text)
+  -- ^ The endpoint's IPv4 address.
+  , endpointIPv6 :: !(Maybe Text)
+  -- ^ The endpoint's IPv6 address.
+  } deriving (Eq, Ord, Show)
+
+-- | An empty endpoint.
+defaultEndpoint :: Endpoint
+defaultEndpoint = Endpoint Nothing Nothing Nothing Nothing
+
+-- | Adds a remote endpoint to a builder. This is mostly useful when generating cross-process spans
+-- where the remote endpoint is not already traced (otherwise Zipkin will associate the spans
+-- correctly automatically). For example when emitting a request to an outside server:
+--
+-- > clientSpanWith (addEndpoint "outside-api") -- ...
+addEndpoint :: Endpoint -> Builder -> Builder
+addEndpoint = appEndo . insertTag endpointKey
+
+-- | Generates an endpoint with the given string as service.
+instance IsString Endpoint where
+  fromString s = defaultEndpoint { endpointService = Just (T.pack s) }
+
+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 ]
+
+parentID :: Set Reference -> Maybe SpanID
+parentID = listToMaybe . catMaybes . fmap go . toList where
+  go (ChildOf d) = Just d
+  go _ = Nothing
+
+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) !Sample
+
+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 (Sample spn tags logs start duration)) =
+    let
+      ctx = spanContext spn
+      requiredKVs =
+        [ "traceId" JSON..= contextTraceID ctx
+        , "name" JSON..= spanName spn
+        , "id" JSON..= contextSpanID ctx
+        , "timestamp" JSON..= microSeconds @Int64 start
+        , "duration" JSON..= microSeconds @Int64 duration
+        , "debug" JSON..= spanIsDebug spn
+        , "tags" JSON..= (publicTags tags <> (JSON.toJSON . T.decodeUtf8 <$> contextBaggages ctx))
+        , "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,77 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+import Control.Monad.Trace
+import Control.Monad.Trace.Class
+import Monitor.Tracing
+import Monitor.Tracing.Local (collectSpanSamples)
+import qualified Monitor.Tracing.Zipkin as ZPK
+
+import Control.Monad (void)
+import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT)
+import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get)
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Concurrent.Lifted
+import Control.Concurrent.STM.Lifted
+
+collectSpans :: (MonadIO m, MonadBaseControl IO m) => TraceT m () -> m [Span]
+collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn
+
+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 $ pure ()
+      fmap spanName spans `shouldBe` []
+    it "should collect a single span when no children are created" $ do
+      spans <- collectSpans (trace "t" { builderSamplingPolicy = Just alwaysSampled } $ pure ())
+      fmap spanName spans `shouldBe` ["t"]
+    it "should be able to stack on top of a ReaderT" $ do
+      let
+        actn = trace "t" { builderSamplingPolicy = Just alwaysSampled } $ do
+          name <- ask
+          trace (builder name) $ pure ()
+      spans <- runReaderT (collectSpans @(ReaderT Text IO) actn) "foo"
+      fmap spanName spans `shouldBe` ["foo", "t"]
+  describe "Zipkin" $ do
+    it "should round-trip a B3 using a single header" $ do
+      let
+        bs = "80f198ee56343ba864fe8b2a57d3eff7-e457b5a2e4d86bd1-1-05e3ac9a4f6e3b90"
+        mbBs = ZPK.b3ToHeaderValue <$> ZPK.b3FromHeaderValue bs
+      mbBs `shouldBe` Just bs
+    it "should have equivalent B3 header representations" $ do
+      let
+        bs = "80f198ee56343ba864fe8b2a57d3eff7-e457b5a2e4d86bd1-1-05e3ac9a4f6e3b90"
+        hdrs = Map.fromList
+          [ ("X-B3-TraceId", "80f198ee56343ba864fe8b2a57d3eff7")
+          , ("X-B3-SpanId", "e457b5a2e4d86bd1")
+          , ("X-B3-ParentSpanId", "05e3ac9a4f6e3b90")
+          , ("X-B3-Sampled", "1") ]
+        Just b3 = ZPK.b3FromHeaderValue bs
+        Just b3' = ZPK.b3FromHeaders hdrs
+      b3 `shouldBe` b3'
+  describe "collectSpanSamples" $ do
+    it "should collect spans which are still pending after the action returns" $ do
+      spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do
+        tmv <- newEmptyTMVarIO
+        void $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000
+        void $ atomically $ readTMVar tmv
+      fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"]
diff --git a/tracing-control.cabal b/tracing-control.cabal
new file mode 100644
--- /dev/null
+++ b/tracing-control.cabal
@@ -0,0 +1,76 @@
+cabal-version: 1.12
+
+name: tracing-control
+version: 0.0.6
+synopsis: Distributed tracing
+description:
+  An OpenTracing-compliant, simple, and extensible distributed tracing library.
+
+  This is a fork of <http://hackage.haskell.org/package/tracing tracing> which
+  switches from <http://hackage.haskell.org/package/unliftio unliftio> to
+  <http://hackage.haskell.org/package/monad-control monad-control>.
+
+category: Web
+homepage: https://github.com/serras/tracing
+license: BSD3
+license-file: LICENSE
+author: Matthieu Monsch, Alejandro Serrano
+maintainer: alejandro.serrano@47deg.com
+copyright: 2020 Matthieu Monsch
+
+build-type: Simple
+extra-source-files: README.md
+
+source-repository head
+  type: git
+  location: https://github.com/serras/tracing
+
+library
+  hs-source-dirs: src
+  exposed-modules:
+      Control.Monad.Trace
+    , Control.Monad.Trace.Class
+    , Monitor.Tracing
+    , Monitor.Tracing.Local
+    , Monitor.Tracing.Zipkin
+  other-modules:
+      Control.Monad.Trace.Internal
+  build-depends:
+      aeson >= 1.4
+    , base >= 4.9 && < 5
+    , base16-bytestring >= 0.1
+    , bytestring >= 0.10
+    , case-insensitive >= 1.2
+    , containers >= 0.6
+    , http-client >= 0.5
+    , lifted-base >= 0.2
+    , monad-control >= 1.0
+    , mtl >= 2.2
+    , network >= 2.8
+    , random >= 1.1
+    , stm >= 2.5
+    , stm-lifted >= 2.5
+    , text >= 1.2
+    , time >= 1.8
+    , transformers >= 0.5
+    , transformers-base >= 0.4
+  ghc-options: -Wall
+  default-language: Haskell2010
+
+test-suite tracing-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  build-depends:
+      base
+    , containers
+    , hspec >=2.6
+    , lifted-base >= 0.2
+    , monad-control >= 1.0
+    , mtl
+    , stm
+    , stm-lifted >= 2.5
+    , text
+    , tracing-control
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  default-language: Haskell2010