initial commit

26 files changed, 3677 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..486084d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+.stack-work/
+ssb-haskell.cabal
+*~
\ No newline at end of file
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..a69b945
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for ssb-haskell
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..72dc60d
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,19 @@
+The MIT License (MIT)
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..75bb728
--- /dev/null
+++ b/README.md
@@ -0,0 +1,67 @@
+# Scuttlebutt in Haskell
+
+[Scuttlebutt](https://www.scuttlebutt.nz/) is a decentralised gossiping
+platform which also works well offline. SSB feed for the project is at
+@f5ABjSMAR95ajlGST63/xx+XUoty53mlSZZ3GhGbQeE=.ed25519.
+
+This project is under active development (in alpha).  USE AT YOUR OWN RISK.
+
+
+## Related Projects
+
+ - [Cryptoscope's SSB](https://github.com/cryptoscope/ssb) - Scuttlebutt implementation in Golang
+ - [Scuttlebutt Types](https://git.joeyh.name/git/haskell-scuttlebutt-types.git/) - data types for common Scuttlebutt messages
+ - [Sunrise Choir's SSB](https://github.com/sunrise-choir) - Scuttlebutt implementation in Rust
+
+## Building and Installation
+
+Haskell [stack](https://docs.haskellstack.org/en/stable/README/) is used to
+build the code and manage dependencies.  See their
+[README](https://docs.haskellstack.org/en/stable/README/) for how to install
+it.
+
+Stack can then be used to:
+
+Build the project
+
+```sh
+stack build
+```
+
+Install the project into your local bin path
+
+```sh
+stack install
+```
+
+Run the project without installing it
+
+```sh
+stack run -- help
+```
+
+## Hosting a SSB Room
+
+You can host an [SSB room](https://github.com/staltz/ssb-room) using this
+project.  SSB peers can then use the room to discover and communicate with each
+other.  For more information, refer to the official project.
+
+```sh
+ssb host-room --help
+# Usage: ssb host-room NAME DESCRIPTION HOSTNAME
+#   host a room
+#
+# Available options:
+#   NAME                     what's the room called
+#   DESCRIPTION              summary of room's purpose
+#   HOSTNAME                 IP address or Domain Name to host on. The Domain Name
+#                            must resolve.
+#   -h,--help                Show this help text
+```
+
+For example:
+
+```sh
+ssb host-room "the-room" "Movie discussion on a cult-classic" room.lets-discuss.org
+# Hosting room for 'net:room.lets-discuss.org:8008~shs:f2Ofh8qBvMNaQSI0RJTf7zr/NEfSOU/RuOXzCMNRu0M=:SSB+Room+PSK3TLYC2T86EHQCUHBUHASCASE18JBV24='
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..74670ba
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,155 @@
+module Main where
+
+import           Protolude               hiding ( Identity )
+import           Data.Default
+import           System.Directory               ( doesFileExist )
+import qualified Data.ByteString.Base64        as Base64
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import qualified Data.Map.Strict               as Map
+
+import           Ssb
+import           Ssb.Aux
+import           Ssb.Identity                  as Ssb
+import           Ssb.Peer                      as Peer
+import           Ssb.Peer.BoxStream            as BoxStream
+import           Ssb.Peer.RPC                  as RPC
+import           Ssb.Peer.TCP                  as TCP
+import           Ssb.Pub                       as Ssb
+import           Ssb.Feed                      as Feed
+import qualified Ssb.Peer.SecretHandshake      as SH
+
+import qualified Ssb.Peer.RPC.Gossip           as Gossip
+import qualified Ssb.Peer.RPC.Room             as Room
+import qualified Ssb.Peer.RPC.WhoAmI           as WhoAmI
+
+import           Data.Aeson                    as Aeson
+
+import qualified Network.Simple.TCP            as TCP
+import qualified Turtle.Options                as Options
+import qualified Turtle
+
+data Command
+  = Connect Text | HostRoom Text Text Text deriving (Show)
+
+aboutMessage :: Ssb.Identity -> Text -> Aeson.Value
+aboutMessage id name =
+  Aeson.toJSON (Map.fromList
+        [ ("type" , "about")
+        , ("about", Ssb.formatPublicKey (Ssb.publicKey id))
+        , ("name" , name)
+        ] :: Map Text Text
+      )
+
+postMessage :: Text -> Aeson.Value
+postMessage post =
+  Aeson.toJSON (Map.fromList [("type", "post"), ("text", post)] :: Map Text Text)
+
+-- Avoid using RPC.Router as it is currently buggy.
+defaultHandler :: IO (Gossip.Gossiper Aeson.Value)
+defaultHandler = Gossip.newGossiper
+--   `withM` (Gossip.newGossiper :: IO (Gossip.Gossiper Aeson.Value))
+--   `withM` (pure WhoAmI.newHandler)
+
+must :: Either a b -> b
+must = fromRight undefined
+
+haskellGuy = must
+  $ Feed.parseFeedID "@f5ABjSMAR95ajlGST63/xx+XUoty53mlSZZ3GhGbQeE=.ed25519"
+
+solarPunkNetwork =
+  must
+    $ Peer.parseMultiAddress
+        "net:pub.solarpunk.network:8008~shs:vU/bDokQrQro6t835MkjGct+dmygIv4zkd4oV3UNhgc="
+
+connectCMD :: Text -> IO ()
+connectCMD peer = do
+  me <- loadOrCreateIdentity
+
+  let peerAddr = must $ Peer.parseMultiAddress peer
+  let peerID   = Peer.id peerAddr
+
+  router <- defaultHandler
+  res    <-
+    TCP.connectRPC router
+                   (Peer.host peerAddr)
+                   (Peer.port peerAddr)
+                   mainNet
+                   me
+                   peerID
+      $ \conn -> do
+
+          let req = (Gossip.newRequest haskellGuy) { Gossip.keys = False
+                                                   , Gossip.live = Just True
+                                                   , Gossip.old  = Just True
+                                                   }
+
+          let myFeed = Feed.empty peerID :: Feed Aeson.Value
+
+          resp <- Gossip.createHistoryStream conn req myFeed $ \feed msg -> do
+            putStrLn (Feed.vmSignedPayload msg)
+            return $ Feed.append feed msg
+
+          case resp of
+            Left err -> print err
+            Right f ->
+                -- Print out the response
+              forM_ f print
+          return ()
+
+  case res of
+    Left  err -> print err
+    Right _   -> return ()
+
+hostRoomCMD :: Text -> Text -> Text -> IO ()
+hostRoomCMD name desc hostname = do
+  me <- loadOrCreateIdentity
+  let roomInvite =
+        Room.Invite { host = hostname, port = "8008", key = publicKey me }
+  putStrLn $ "Hosting room for '" <> Room.formatInvite roomInvite <> "'"
+
+  router <- defaultHandler
+  TCP.serveRPC router hostname (Room.port roomInvite) mainNet me
+
+parser :: Options.Parser Command
+parser =
+  Options.subcommand
+      "connect"
+      "connect to a peer"
+      (Connect <$> Options.argText "peer" "whom to connect to, not really useful now")
+    <|> Options.subcommand
+          "host-room"
+          "host a room"
+          (   HostRoom
+          <$> Options.argText "name" "what's the room called"
+          <*> Options.argText "description" "summary of room's purpose"
+          <*> Options.argText "hostname" "IP address or Domain Name to host on. The Domain Name must resolve."
+          )
+
+-- | keysFile is where the encryption keys are stored.
+keysFile = "keys.json"
+
+loadOrCreateIdentity :: IO Ssb.Identity
+loadOrCreateIdentity = do
+  unlessM (doesFileExist keysFile) $ do
+    i <- newIdentity
+    Aeson.encodeFile keysFile i
+
+  i <- Aeson.decodeFileStrict keysFile
+  case i of
+    Nothing -> die "badly formatted key file"
+    Just i  -> return i
+
+main :: IO ()
+main = do
+  ssbInit
+
+  -- Use an external command to support SSB legacy message serialization.
+  -- initV8Encoder "ssb-message-encoder"
+
+  id <- loadOrCreateIdentity
+  x  <- Options.options "Secure Scuttlebutt" parser
+  case x of
+    Connect peer            -> connectCMD peer
+    HostRoom name desc hostname -> hostRoomCMD name desc hostname
diff --git a/package.yaml b/package.yaml
new file mode 100644
index 0000000..a306c55
--- /dev/null
+++ b/package.yaml
@@ -0,0 +1,74 @@
+name:                ssb-haskell
+version:             0.1.0.0
+license:             MIT
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         "Secure Scuttlebutt in Haskell"
+
+dependencies:
+- aeson
+- base >= 4.7 && < 5
+- base64-bytestring
+- bytestring
+- cereal
+- containers
+- cryptohash-sha256
+- data-default
+- directory
+- either
+- exceptions
+- network-simple
+- pipes
+- process
+- protolude
+- saltine
+- stm
+- text
+- time
+- turtle
+- unordered-containers
+
+library:
+  source-dirs: src
+
+executables:
+  ssb:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - ssb-haskell
+
+tests:
+  ssb-haskell-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - ssb-haskell
+
+default-extensions:
+- AllowAmbiguousTypes
+- BangPatterns
+- DeriveGeneric
+- DuplicateRecordFields
+- MultiParamTypeClasses
+- MultiWayIf
+- NoImplicitPrelude
+- OverloadedStrings
diff --git a/src/Sodium.hs b/src/Sodium.hs
new file mode 100644
index 0000000..eb11bb2
--- /dev/null
+++ b/src/Sodium.hs
@@ -0,0 +1,99 @@
+-- | This module implements additional bindings for libsodium which are
+-- required for the SSB handshake.
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Sodium where
+
+import           Data.ByteString.Unsafe
+import qualified Data.ByteString                   as BS
+import Protolude
+import           Foreign.C
+import           Foreign.Ptr
+import           Foreign.Marshal.Alloc
+import           Foreign.Storable
+import           System.IO.Unsafe
+
+import qualified Crypto.Saltine.Internal.ByteSizes as Bytes
+import Crypto.Saltine.Class
+import qualified Crypto.Saltine.Core.Box as Box
+import qualified Crypto.Saltine.Core.Sign as Sign
+
+foreign import ccall "crypto_sign_ed25519_sk_to_curve25519"
+  c_sign_ed25519_sk_to_curve25519 :: Ptr CChar
+                                  -- ^ Converted Curve25519 secret key buffer
+                                  -> Ptr CChar
+                                  -- ^ Ed25519 secret key buffer
+                                  -> IO CInt
+                                  -- ^ Always 0
+
+foreign import ccall "crypto_sign_ed25519_pk_to_curve25519"
+  c_sign_ed25519_pk_to_curve25519 :: Ptr CChar
+                                  -- ^ Converted Curve25519 public key buffer
+                                  -> Ptr CChar
+                                  -- ^ Ed25519 public key buffer
+                                  -> IO CInt
+                                  -- ^ Always 0
+
+
+-- | Size of a @curve_25519@-generated secret key
+curve25519SK    = 64
+
+newtype Curve25519SecretKey = CSK ByteString deriving (Eq, Ord)
+
+instance IsEncoding Curve25519SecretKey where
+  decode v = if BS.length v == curve25519SK
+           then Just (CSK v)
+           else Nothing
+  {-# INLINE decode #-}
+  encode (CSK v) = v
+  {-# INLINE encode #-}
+
+secretKeyToCurve25519 :: Sign.SecretKey -> Curve25519SecretKey
+secretKeyToCurve25519 sk = unsafePerformIO $ do
+    (_err, csk) <-  buildUnsafeByteString' curve25519PK $ \cskbuf ->
+      constByteStrings [skbuf] $ \[(skbuf', _)] ->
+        c_sign_ed25519_sk_to_curve25519 cskbuf skbuf'
+    return $ CSK csk
+  where
+    skbuf = encode sk :: ByteString
+
+-- | Size of a @curve_25519@-generated public key
+curve25519PK    = 32
+
+newtype Curve25519PublicKey = CPK ByteString deriving (Eq, Ord)
+
+instance IsEncoding Curve25519PublicKey where
+  decode v = if BS.length v == curve25519PK
+           then Just (CPK v)
+           else Nothing
+  {-# INLINE decode #-}
+  encode (CPK v) = v
+  {-# INLINE encode #-}
+
+
+publicKeyToCurve25519 :: Box.PublicKey -> Curve25519PublicKey
+publicKeyToCurve25519 pk = unsafePerformIO $ do
+    (_err, cpk) <-  buildUnsafeByteString' curve25519PK $ \cpkbuf ->
+      constByteStrings [pkbuf] $ \[(pkbuf', _)] ->
+        c_sign_ed25519_pk_to_curve25519 cpkbuf pkbuf'
+    return $ CPK cpk
+  where
+    pkbuf = encode pk :: ByteString
+
+-- | Copied from Saltine :)
+
+-- | Convenience function for accessing constant C strings
+constByteStrings :: [ByteString] -> ([CStringLen] -> IO b) -> IO b
+constByteStrings =
+  foldr (\v kk -> \k -> (unsafeUseAsCStringLen v) (\a -> kk (\as -> k (a:as)))) ($ [])
+
+-- | Slightly safer cousin to 'buildUnsafeByteString' that remains in the
+-- 'IO' monad.
+buildUnsafeByteString' :: Int -> (Ptr CChar -> IO b) -> IO (b, ByteString)
+buildUnsafeByteString' n k = do
+  ph  <- mallocBytes n
+  bs  <- unsafePackMallocCStringLen (ph, fromIntegral n)
+  out <- unsafeUseAsCString bs k
+  return (out, bs)
+
diff --git a/src/Ssb.hs b/src/Ssb.hs
new file mode 100644
index 0000000..e9bbb5d
--- /dev/null
+++ b/src/Ssb.hs
@@ -0,0 +1,10 @@
+module Ssb
+  ( ssbInit
+  )
+where
+
+import           Protolude
+import qualified Crypto.Saltine                as Nacl
+
+ssbInit :: IO ()
+ssbInit = Nacl.sodiumInit
diff --git a/src/Ssb/Aux.hs b/src/Ssb/Aux.hs
new file mode 100644
index 0000000..4be61b9
--- /dev/null
+++ b/src/Ssb/Aux.hs
@@ -0,0 +1,67 @@
+module Ssb.Aux where
+
+import           Protolude
+
+import           Data.Aeson                    as Aeson
+import           Data.ByteString.Lazy          as BS (toStrict)
+import           Data.Default
+import           Data.Serialize                as Serialize
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import           Control.Concurrent.STM
+import           System.IO                      ( hFlush
+                                                , hGetLine
+                                                , hSetBinaryMode
+                                                )
+import           System.Process
+
+
+-- | Convertible  describes instances where types can be easily converted.
+class Convertible a b where
+  convert :: a -> b
+
+-- | decodeJSON deserializes the JSON bytestring.
+-- It is a reimplementation Aeson's eitherDecodeStrict which returns Text
+-- instead of String.
+decodeJSON :: (FromJSON a) => ByteString -> Either Text a
+decodeJSON = mapLeft toS . Aeson.eitherDecodeStrict
+
+encodeJSON :: (ToJSON a) => a -> ByteString
+encodeJSON = BS.toStrict . Aeson.encode
+
+encodeByteString :: Serialize.Serialize a => a -> ByteString
+encodeByteString = Serialize.encode
+
+decodeByteString :: Serialize.Serialize a => ByteString -> Either Text a
+decodeByteString a = mapLeft toS $ Serialize.decode a
+
+withErr :: Text -> Maybe a -> Either Text a
+withErr = maybeToRight
+
+error :: Text -> Either Text a
+error = Left
+
+maybeWord8 :: Int -> Either Text Word8
+maybeWord8 arg = if arg >= min && arg <= max
+  then return $ fromIntegral arg
+  else Left "out of bounds"
+ where
+  min = fromIntegral (minBound :: Word8)
+  max = fromIntegral (maxBound :: Word8)
+
+-- | TODO: kill command forked by forkCommand
+command :: Text -> TMVar ByteString -> TMVar ByteString -> IO ()
+command cmd input output = do
+  (hIn, hOut, hErr, hProc) <- runInteractiveCommand (toS cmd)
+  hSetBinaryMode hIn  False
+  hSetBinaryMode hOut False
+  hSetBinaryMode hErr False
+  let loop = do
+        v <- atomically $ takeTMVar input
+        hPutStr hIn (toS v :: [Char])
+        hFlush hIn
+        v' <- hGetLine hOut
+        atomically $ putTMVar output (toS v')
+        loop
+  loop
diff --git a/src/Ssb/Discovery.hs b/src/Ssb/Discovery.hs
new file mode 100644
index 0000000..352020e
--- /dev/null
+++ b/src/Ssb/Discovery.hs
@@ -0,0 +1,22 @@
+-- | This module implements local discovery of Scuttlebutt peers.
+--
+-- https://ssbc.github.io/scuttlebutt-protocol-guide/#discovery
+
+module Ssb.Discovery where
+
+import           Protolude
+
+import           Ssb.Network
+import           Ssb.Identity
+
+-- | default Scuttlebutt Server Port
+defaultPort :: Port
+defaultPort = "8008"
+
+-- | Advertisement messages are emitted on the local network for discovery of
+-- peers.
+data Advertisement = Advertisement
+  { ipAddress :: Host
+  , port      :: Port
+  , publicKey :: PublicKey
+  } deriving (Eq)
diff --git a/src/Ssb/Feed.hs b/src/Ssb/Feed.hs
new file mode 100644
index 0000000..f4e96c2
--- /dev/null
+++ b/src/Ssb/Feed.hs
@@ -0,0 +1,342 @@
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+
+module Ssb.Feed where
+
+import           Protolude               hiding ( Identity
+                                                , sequence
+                                                , hash
+                                                )
+
+import           Control.Monad.Fail
+import           Control.Concurrent.STM
+import           Data.Aeson                     ( FromJSON
+                                                , ToJSON
+                                                )
+import qualified Data.Map.Strict               as Map
+
+import qualified Crypto.Hash.SHA256            as SHA256
+import qualified Crypto.Saltine.Class          as Nacl
+import qualified Crypto.Saltine.Core.Sign      as NaclSign
+
+import qualified Data.Aeson                    as Aeson
+import           Data.Aeson                    as Aeson (object, (.=))
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Base64        as Base64
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import qualified Data.HashMap.Strict           as HashMap
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import           Data.Time.Clock.POSIX          ( getPOSIXTime )
+import           Numeric.Natural
+import           System.IO.Unsafe
+
+import           Ssb.Aux
+import           Ssb.Identity
+
+import           Turtle
+
+type Time = Int
+
+newtype FeedID = FeedID PublicKey
+  deriving (Eq,Generic,Ord,Show)
+
+formatFeedID :: FeedID -> Text
+formatFeedID = formatPublicKey . extractFeedID
+
+extractFeedID :: FeedID -> PublicKey
+extractFeedID (FeedID pubKey) = pubKey
+
+parseFeedID :: Text -> Either Text FeedID
+parseFeedID arg = FeedID <$> parsePublicKey arg
+
+instance FromJSON FeedID where
+  parseJSON = Aeson.withText "FeedID" $ \v -> case parseFeedID v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON FeedID where
+  toJSON arg = Aeson.String $ formatFeedID arg
+
+newtype MessageID = MessageID ByteString
+  deriving (Eq,Show)
+
+newMessageID :: ByteString -> MessageID
+newMessageID buf = MessageID (SHA256.hash buf)
+
+extractMessageID :: MessageID -> ByteString
+extractMessageID (MessageID buf) = buf
+
+-- | return the Humand Readable form.
+-- Format of '%[base64 messageId].sha256', the '.sha256' is appended for
+-- forward compatibility, and is currently assumed.
+formatMessageID :: MessageID -> Text
+formatMessageID (MessageID buf) = "%" <> toS (Base64.encode buf) <> ".sha256"
+
+-- | TODO: make safe
+parseMessageID :: Text -> Either Text MessageID
+parseMessageID arg = decode $ T.dropEnd constLen $ T.drop 1 arg
+ where
+  constLen = T.length ".sha256"
+  decode :: Text -> Either Text MessageID
+  decode = mapRight MessageID . mapLeft toS . Base64.decode . toS
+
+instance FromJSON MessageID where
+  parseJSON = Aeson.withText "MessageID" $ \v -> case parseMessageID v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON MessageID where
+  toJSON arg = Aeson.String $ formatMessageID arg
+
+data HashType = SHA256
+  deriving (Eq,Generic,Show)
+
+formatHashType :: HashType -> Text
+formatHashType SHA256 = "sha256"
+
+parseHashType :: Text -> Either Text HashType
+parseHashType "sha256" = Right SHA256
+parseHashType _        = Left "unknown hash"
+
+instance FromJSON HashType where
+  parseJSON = Aeson.withText "HashType" $ \v -> case parseHashType v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON HashType where
+  toJSON arg = Aeson.String $ formatHashType arg
+
+data Signature = Signature ByteString
+  deriving (Generic,Eq,Show)
+
+extractSignature :: Signature -> ByteString
+extractSignature (Signature buf) = buf
+
+formatSignature :: Signature -> Text
+formatSignature (Signature buf) = toS (Base64.encode buf) <> ".sig.ed25519"
+
+parseSignature :: Text -> Either Text Signature
+parseSignature txt = decode $ T.dropEnd constLen txt
+ where
+  constLen = T.length ".sig.ed25519"
+  decode :: Text -> Either Text Signature
+  decode = mapRight Signature . mapLeft toS . Base64.decode . toS
+
+instance FromJSON Signature where
+  parseJSON = Aeson.withText "Signature" $ \v -> case parseSignature v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON Signature where
+  toJSON arg = Aeson.String $ formatSignature arg
+
+data Message a = Message
+  { previous :: Maybe MessageID
+  , author :: FeedID
+  , sequence :: Natural
+  , timestamp :: Time
+  , hash :: HashType
+  , content :: a
+  , signature :: Maybe Signature
+  } deriving (Generic,Eq,Show)
+
+instance FromJSON a => FromJSON (Message a)
+
+instance (ToJSON a) => ToJSON (Message a)
+
+newtype MessageNoSig a = MessageNoSig (Message a)
+  deriving (Generic, Eq, Show)
+
+instance (ToJSON a) => ToJSON (MessageNoSig a) where
+  toJSON (MessageNoSig msg) = object [
+      "previous" .= previous msg
+    , "author" .= author msg
+    , "timestamp" .= timestamp msg
+    , "sequence" .= sequence msg
+    , "content" .= content msg
+    , "hash" .= hash msg
+    ]
+
+data Feed a = Feed Identity [VerifiableMessage a]
+  deriving (Eq,Show)
+
+empty id = Feed id []
+
+instance Foldable Feed where
+  foldMap f (Feed id msgs) = foldMap f (content . vmMessage <$> msgs)
+
+data Feeds a = Feeds (Map FeedID (Feed a))
+
+emptyFeeds :: ToJSON a => Feeds a
+emptyFeeds = (Feeds Map.empty)
+
+lookup :: ToJSON a => FeedID -> Feeds a -> Maybe (Feed a)
+lookup id (Feeds m) = Map.lookup id m
+
+insert :: ToJSON a => Feed a -> Feeds a -> Feeds a
+insert feed (Feeds m) = Feeds (Map.insert (id feed) feed m)
+ where
+  id (Feed id _) = FeedID (publicKey id)
+
+-- | Message Verification
+--  Legacy verification of a Message requires keeping track of the JSON value
+--  ordering.  Haskell's underlying JSON serialization mechanisms cannot be
+--  relied on to preserve this.
+--
+-- There are two values which use this funny encoding, the message reference
+-- -and- the signature.
+
+-- | VerifiableMessage keeps track of the original JSON payload for signature
+-- verification.
+data VerifiableMessage a = VerifiableMessage
+  { vmMessage :: Message a
+  , vmMessageID :: MessageID
+  , vmSignature :: Signature
+  , vmSignedPayload :: ByteString
+  } deriving (Generic,Eq,Show)
+
+-- TODO: verify message on creation in newVerifiableMessage
+
+withSignature :: Signature -> ByteString -> ByteString
+withSignature signature buf = (dropEnd (BS.length endTxt) buf) <> sigTxt
+ where
+  dropEnd num = BS.reverse . (BS.drop num) . BS.reverse
+  sigTxt =
+    ",\n  \"signature\": "
+      <> "\""
+      <> toS (formatSignature signature)
+      <> "\""
+      <> endTxt
+  endTxt = "\n}"
+
+-- | TODO: implement stricter version of withoutSignature
+withoutSignature :: ByteString -> ByteString
+withoutSignature buf =
+  appendToEnd "\n}"
+    $ BS.reverse
+    $ BS.drop (BS.length signaturePattern)
+    $ snd
+    $ BS.breakSubstring (BS.reverse signaturePattern) (BS.reverse buf)
+ where
+  appendToEnd      = \x y -> BS.append y x
+  signaturePattern = ",\n  \"signature\":"
+
+newVerifiableMessage
+  :: ByteString -> Message a -> IO (Either Text (VerifiableMessage a))
+newVerifiableMessage origJSONPayload msg = do
+  signedPayload <- encodeForSigning False origJSONPayload
+  return $ do
+    signature'     <- withErr "expected message signature" $ signature msg
+    signedPayload' <- signedPayload
+    return $ VerifiableMessage { vmMessage       = msg
+                               , vmMessageID     = newMessageID signedPayload'
+                               , vmSignature     = signature'
+                               , vmSignedPayload = signedPayload'
+                               }
+
+decodeJSONVerifiableMessage
+  :: FromJSON a => ByteString -> IO (Either Text (VerifiableMessage a))
+decodeJSONVerifiableMessage buf =
+  either (return . Left) (newVerifiableMessage buf) (decodeJSON buf)
+
+encodeJSONVerifiableMessage :: VerifiableMessage a -> ByteString
+encodeJSONVerifiableMessage = vmSignedPayload
+
+atMayFeed :: Int -> Feed a -> Maybe (VerifiableMessage a)
+atMayFeed i (Feed _ msgs) = atMay msgs i
+
+-- | append verifies and appends the Message to the Feed, returning an error if
+-- verification fails.
+append :: ToJSON a => Feed a -> VerifiableMessage a -> Either Text (Feed a)
+append (Feed id msgs) msg = do
+  if (verify id msg)
+    then (return (Feed id (msgs ++ [msg])))
+    else (error "verification failed")
+
+appendContent :: ToJSON a => Feed a -> a -> IO (Either Text (Feed a))
+appendContent (Feed id msgs) content = do
+  timestamp <- (1000 *) <$> getPOSIXTime
+  let msg = Message { previous  = vmMessageID <$> atMay msgs (length msgs - 1)
+                    , author    = FeedID (publicKey id)
+                    , sequence  = fromIntegral (length msgs) + 1
+                    , timestamp = round timestamp
+                    , hash      = SHA256
+                    , content   = content
+                    , signature = Nothing
+                    }
+  vMsg <- signMessage id msg
+  return $ (\x -> Feed id (msgs ++ [x])) <$> vMsg
+
+signMessage
+  :: ToJSON a => Identity -> Message a -> IO (Either Text (VerifiableMessage a))
+signMessage id msg = do
+  buf' <- encodeForSigning True $ encodeJSON (MessageNoSig msg)
+
+  let args = do
+        key  <- withErr "private key required for signing" $ privateKey id
+        key' <-
+          withErr "could not decode private key"
+          $ Nacl.decode
+          . extractPrivateKey
+          $ key
+        buf'' <- buf'
+        return (key', buf'')
+  case args of
+    Right (key, buf) -> do
+      let signature = Signature (NaclSign.signDetached key buf)
+      vMsg <- newVerifiableMessage (withSignature signature buf)
+                           msg { signature = Just signature }
+      return $ do
+          vMsg' <- vMsg
+          if (verify id vMsg')
+            then (return vMsg')
+            else (error "signing failed verification")
+    Left err -> return $ error err
+
+verify :: ToJSON a => Identity -> VerifiableMessage a -> Bool
+verify id msg = do
+  let args = do
+        key <- withErr "could not decode public key"
+          $ Nacl.decode (extractPublicKey (publicKey id))
+        let sig = extractSignature $ vmSignature msg
+        let buf = withoutSignature $ vmSignedPayload msg
+        return (key, sig, buf)
+  case args of
+    Right (key, sig, buf) -> NaclSign.signVerifyDetached key sig buf
+    Left  err             -> False
+
+{-# NOINLINE v8Input #-}
+v8Input :: TMVar ByteString
+v8Input = unsafePerformIO newEmptyTMVarIO
+
+{-# NOINLINE v8Output #-}
+v8Output :: TMVar ByteString
+v8Output = unsafePerformIO newEmptyTMVarIO
+
+{-# NOINLINE isV8EncoderEnabled #-}
+isV8EncoderEnabled :: TMVar Bool
+isV8EncoderEnabled = unsafePerformIO newEmptyTMVarIO
+
+initV8Encoder :: Text -> IO ()
+initV8Encoder cmd = do
+  atomically $ putTMVar isV8EncoderEnabled True
+  forkIO $ command cmd v8Input v8Output
+  return ()
+
+encodeForSigning :: Bool -> ByteString -> IO (Either Text ByteString)
+encodeForSigning contentOrder arg = do
+  isEnabled <- atomically $ isEmptyTMVar isV8EncoderEnabled
+  if not isEnabled
+    then
+      return (error "external V8 byte string encoder not initialized")
+    else do
+      atomically $ putTMVar v8Input (cmd <> toS arg)
+      ret <- atomically $ takeTMVar v8Output
+      let ret' = Base64.decode (toS ret)
+      return $ mapLeft toS ret'
+ where
+  cmd = if contentOrder
+    then "y"
+    else "n"
diff --git a/src/Ssb/Identity.hs b/src/Ssb/Identity.hs
new file mode 100644
index 0000000..e3fa4dc
--- /dev/null
+++ b/src/Ssb/Identity.hs
@@ -0,0 +1,82 @@
+module Ssb.Identity where
+
+import           Protolude               hiding ( Identity )
+import           Control.Monad.Fail
+import           Data.Aeson              hiding ( encode )
+import qualified Data.ByteString.Base64        as Base64
+import qualified Crypto.Saltine.Core.Sign      as Nacl
+import qualified Crypto.Saltine.Class          as Nacl
+
+import           Data.Serialize                 ( Serialize )
+import           Data.Either.Combinators        ( mapLeft )
+import qualified Data.Text                     as T
+
+newtype PrivateKey = PrivateKey ByteString
+  deriving (Eq,Generic,Ord,Show)
+
+extractPrivateKey :: PrivateKey -> ByteString
+extractPrivateKey (PrivateKey a) = a
+
+instance Serialize PrivateKey
+
+formatPrivateKey :: PrivateKey -> Text
+formatPrivateKey (PrivateKey buf) = "@" <> pubKey <> ".ed25519"
+  where pubKey = toS $ Base64.encode buf
+
+parsePrivateKey :: Text -> Either Text PrivateKey
+parsePrivateKey arg = decode $ T.dropEnd constLen $ T.drop 1 arg
+ where
+  constLen = T.length ".ed25519"
+  decode   = fmap PrivateKey . mapLeft toS . Base64.decode . toS
+
+instance FromJSON PrivateKey where
+  parseJSON = withText "PrivateKey" $ \v -> case parsePrivateKey v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON PrivateKey where
+  toJSON arg = String $ formatPrivateKey arg
+
+newtype PublicKey = PublicKey ByteString
+  deriving (Eq,Generic,Ord,Show)
+
+extractPublicKey :: PublicKey -> ByteString
+extractPublicKey (PublicKey a) = a
+
+instance Serialize PublicKey
+
+formatPublicKey :: PublicKey -> Text
+formatPublicKey (PublicKey buf) = "@" <> pubKey <> ".ed25519"
+  where pubKey = toS $ Base64.encode buf
+
+parsePublicKey :: Text -> Either Text PublicKey
+parsePublicKey arg = decode $ T.dropEnd constLen $ T.drop 1 arg
+ where
+  constLen = T.length ".ed25519"
+  decode   = fmap PublicKey . mapLeft toS . Base64.decode . toS
+
+instance FromJSON PublicKey where
+  parseJSON = withText "PublicKey" $ \v -> case parsePublicKey v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON PublicKey where
+  toJSON arg = String $ formatPublicKey arg
+
+-- | Identity represents a user or agent on the scuttlebutt network.  Each of
+-- these entities own their own append-only message feed.
+data Identity = Identity
+  { privateKey :: Maybe PrivateKey
+  , publicKey :: PublicKey
+  } deriving (Eq,Generic,Show)
+
+instance FromJSON Identity
+
+instance ToJSON Identity
+
+newIdentity :: IO Identity
+newIdentity = do
+  (secret, public) <- Nacl.newKeypair
+  return Identity { privateKey = Just $ PrivateKey $ Nacl.encode secret
+                  , publicKey  = PublicKey $ Nacl.encode public
+                  }
diff --git a/src/Ssb/Network.hs b/src/Ssb/Network.hs
new file mode 100644
index 0000000..62d82b1
--- /dev/null
+++ b/src/Ssb/Network.hs
@@ -0,0 +1,8 @@
+-- | This module defines common networking types used in the codebase.
+
+module Ssb.Network where
+
+import           Protolude
+
+type Host = Text
+type Port = Text
diff --git a/src/Ssb/Peer.hs b/src/Ssb/Peer.hs
new file mode 100644
index 0000000..75078ff
--- /dev/null
+++ b/src/Ssb/Peer.hs
@@ -0,0 +1,60 @@
+-- | This module implements Scuttlebutt Peers
+--
+-- https://ssbc.github.io/scuttlebutt-protocol-guide/#peer-connections
+
+module Ssb.Peer where
+
+import           Protolude               hiding ( Identity )
+import           Control.Arrow ((***))
+import qualified Data.ByteString.Base64        as Base64
+import qualified Network.Simple.TCP            as TCP
+import qualified Data.Text as Text
+
+import           Ssb.Identity
+import           Ssb.Network
+import qualified Ssb.Peer.SecretHandshake      as SH
+import qualified Ssb.Peer.RPC                  as RPC
+
+-- | TODO: Is there a standard way to re-export types?
+type NetworkIdentifier = SH.NetworkIdentifier
+
+-- | mainNet is the default Network where one will find most scuttlebutt
+-- traffic.
+mainNet :: NetworkIdentifier
+mainNet = Base64.decodeLenient "1KHLiKZvAvjbY1ziZEHMXawbCEIM6qwjCDm3VYRan/s="
+
+-- TODO: Perfect MultiAddress implementation
+
+data MultiAddress = MultiAddress
+    { protocol :: Text
+    , host     :: Host
+    , port     :: Port
+    , key      :: PublicKey
+    } deriving (Eq, Show)
+
+id :: MultiAddress -> Identity
+id ma = Identity Nothing (key ma)
+
+parseMultiAddress :: Text -> Either Text MultiAddress
+parseMultiAddress txt = do
+    let (protocol, postProtocol) = split ":" txt
+    let (addressPort, postAddress) = split "~" postProtocol
+    let (address, port) = splitOnEnd ":" addressPort
+    let (hashType, key) = split ":" postAddress
+    return MultiAddress
+      { protocol = protocol
+      , host = address
+      , port = port
+      , key  = PublicKey $ Base64.decodeLenient $ toS key
+      }
+  where
+    split c arg = (identity *** Text.drop 1) $ Text.breakOn c arg
+    splitOnEnd c arg = (Text.dropEnd 1 *** identity) $ Text.breakOnEnd c arg
+
+-- Example string "net:some.ho.st:8008~shs:SomeActuallyValidPubKey="
+formatMultiAddress :: MultiAddress -> Text
+formatMultiAddress addr =
+    protocol addr <> ":"
+    <> host addr <> ":" <> port addr
+    <> "~shs:"
+    <> formatPublicKey (key addr)
diff --git a/src/Ssb/Peer/BoxStream.hs b/src/Ssb/Peer/BoxStream.hs
new file mode 100644
index 0000000..d804e56
--- /dev/null
+++ b/src/Ssb/Peer/BoxStream.hs
@@ -0,0 +1,367 @@
+-- | This module implements Scuttlebutt's Box Stream.
+--
+-- For more information kindly refer the to protocol guide
+-- https://ssbc.github.io/scuttlebutt-protocol-guide
+
+module Ssb.Peer.BoxStream where
+
+import           Protolude               hiding ( Identity )
+
+import qualified Crypto.Hash.SHA256            as SHA256
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Base64        as Base64
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import           Control.Concurrent.STM
+import qualified Data.Serialize                as Serialize
+import qualified Data.Serialize.Put            as Serialize
+import qualified Network.Simple.TCP            as TCP
+
+import           Ssb.Aux
+import qualified Ssb.Identity                  as SSB
+import qualified Ssb.Peer.SecretHandshake      as SH
+
+import qualified Crypto.Saltine.Class          as Nacl
+import qualified Crypto.Saltine.Core.Auth      as NaclAuth
+import qualified Crypto.Saltine.Core.SecretBox as Nacl
+import qualified Crypto.Saltine.Core.ScalarMult
+                                               as Nacl
+
+import           Pipes
+import qualified Pipes.Prelude                 as P
+
+-- | HeaderLength is the length of a Box Stream header in bytes
+headerLength :: Int
+headerLength = 34
+
+-- | MaxBodyLength is the maximum Box Stream body length in bytes
+maxBodyLength :: Int
+maxBodyLength = 4096
+
+data Header = Header
+    { bodyLength :: Word16
+    , authTag    :: AuthTag
+    } deriving (Eq,Generic,Show)
+
+instance Serialize.Serialize Header
+
+-- | GoodBye is the message signalling the end of the Box Stream
+goodByeHeader :: Header
+goodByeHeader = Header
+  { bodyLength = 0
+  , authTag    = AuthTag $ BS.pack $ replicate authTagLength 0
+  }
+
+newHeader :: ByteString -> ByteString -> Either Text Header
+newHeader authTag body = do
+  let bodyLength = BS.length body
+  if bodyLength >= maxLength
+    then Left "body size too big"
+    else return $ Header { bodyLength = fromIntegral bodyLength
+                         , authTag    = AuthTag authTag
+                         }
+  where maxLength = fromIntegral (maxBound :: Word16)
+
+data Message = Message
+  { header :: Header
+  , body   :: ByteString
+  }
+
+encryptMessage :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text ByteString
+encryptMessage key nonce buf = do
+  let (authTag, ebody) = Nacl.secretboxDetached key bodyNonce buf
+  header <- newHeader authTag ebody
+  let eheader = Nacl.secretbox key headerNonce $ Serialize.encode header
+  return $ eheader <> ebody
+ where
+  headerNonce = nonce
+  bodyNonce   = increment nonce
+
+-- | A breakdown of the message alignment would be nice
+-- | Problem is the body size is variable
+
+-- | TODO: deduplicate
+-- | TODO: safe take, safe tail
+
+-- TODO: handle goodbye
+
+-- TODO: Properly describe the function w/ Nonce update
+--   The decryption / update functions should return the nonce after
+--   evaluation.  This increases the difficulty for describing in the language.
+--   Current work around is to model the behaviour outside the function.
+
+decryptHeader :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text Header
+decryptHeader key nonce buf = do
+  let eheader = BS.take headerLength buf
+  headerBuf <- withErr (errHeader eheader)
+    $ Nacl.secretboxOpen key nonce eheader
+  decodeByteString headerBuf :: Either Text Header
+  where errHeader h = "could not decrypt header: " <> (show h :: Text)
+
+decryptMessage :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text ByteString
+decryptMessage key nonce buf = do
+  header <- decryptHeader key nonce buf
+
+  let rest = BS.drop headerLength buf
+  ebody <- withErr "message body is smaller than messages body length"
+    $ takeMay (fromIntegral $ bodyLength header) rest
+  withErr (errBody ebody) $ Nacl.secretboxOpenDetached
+    key
+    (increment nonce)
+    (extractAuthTag $ authTag header)
+    ebody
+  where errBody b = "could not decrypt body: " <> (show b :: Text)
+
+goodBye :: ConnState -> ByteString
+goodBye state = Nacl.secretbox (key state) (nonce state) $ encodeByteString goodByeHeader
+
+-- | clientToServerKey is the key for client to server stream encryption.
+clientToServerKey :: SH.SharedSecrets -> Either Text Nacl.Key
+clientToServerKey sharedSecrets = do
+  secretB <- withErr errMissingB $ SH.secretB sharedSecrets
+  let layer1 = SHA256.hash $ SHA256.hash
+        (  SH.network sharedSecrets
+        <> Nacl.encode (SH.secretab sharedSecrets)
+        <> Nacl.encode (SH.secretaB sharedSecrets)
+        <> Nacl.encode (SH.secretAb sharedSecrets)
+        )
+  let layer2 = SHA256.hash $ layer1 <> SSB.extractPublicKey secretB
+  maybeToRight errKey $ Nacl.decode layer2
+ where
+  errMissingB = "missing shared secret B"
+  errKey      = "badly formatted sodium secret box key"
+
+-- | serverToClientKey is the key for server to client stream encryption.
+serverToClientKey :: SH.SharedSecrets -> Either Text Nacl.Key
+serverToClientKey sharedSecrets = do
+  secretA <- withErr errMissingA $ SH.secretA sharedSecrets
+  let layer1 = SHA256.hash
+        (SHA256.hash
+          (  SH.network sharedSecrets
+          <> Nacl.encode (SH.secretab sharedSecrets)
+          <> Nacl.encode (SH.secretaB sharedSecrets)
+          <> Nacl.encode (SH.secretAb sharedSecrets)
+          )
+        )
+  let layer2 = SHA256.hash (layer1 <> SSB.extractPublicKey secretA)
+  maybeToRight errKey $ Nacl.decode layer2
+ where
+  errMissingA = "missing shared secret A"
+  errKey      = "badly formatted sodium secret box key"
+
+clientToServerNonce :: SH.SharedSecrets -> Either Text Nacl.Nonce
+clientToServerNonce sharedSecrets = do
+  secretb <- withErr errMissing $ SH.secretb sharedSecrets
+  key     <- withErr errBadNet $ Nacl.decode $ SH.network sharedSecrets
+  let auth     = NaclAuth.auth key (SSB.extractPublicKey secretb)
+  let noncebuf = BS.take 24 $ Nacl.encode auth
+  withErr errMsg $ Nacl.decode noncebuf
+ where
+  errBadNet  = "badly formatted network id"
+  errMissing = "missing shared secret a"
+  errMsg     = "badly formatted sodium nonce"
+
+serverToClientNonce :: SH.SharedSecrets -> Either Text Nacl.Nonce
+serverToClientNonce sharedSecrets = do
+  a   <- withErr errMissing $ SH.secreta sharedSecrets
+  key <- withErr errBadNet $ Nacl.decode $ SH.network sharedSecrets
+  let auth     = NaclAuth.auth key (SSB.extractPublicKey a)
+  let noncebuf = BS.take 24 $ Nacl.encode auth
+  withErr errMsg $ Nacl.decode noncebuf
+ where
+  errMissing = "missing shared secret a"
+  errBadNet  = "badly formatted network id"
+  errHMAC    = "badly formatted HMAC"
+  errMsg     = "badly formatted sodium nonce"
+
+-- The documentation's Client / Server key and nonce terminology is replaced
+-- with local/remote fields to simplify implmenentation.
+data ConnState = ConnState {
+      key           :: Nacl.Key
+    , nonce         :: Nacl.Nonce
+    , remoteKey     :: Nacl.Key
+    , remoteNonce   :: Nacl.Nonce
+    , buffer        :: ByteString
+    , socket        :: TCP.Socket
+    }
+
+newtype Conn = Conn ((TMVar ConnState),(TMVar ConnState))
+
+inc :: (Word64, Word64, Word64) -> (Word64, Word64, Word64)
+inc (w1, w2, w3) | w3 /= maxBound = (w1, w2, w3 + 1)
+                 | w2 /= maxBound = (w1, w2 + 1, 0)
+                 | w1 /= maxBound = (w1 + 1, 0, 0)
+                 | otherwise      = (0, 0, 0)
+
+
+-- TODO : finish me
+increment :: Nacl.Nonce -> Nacl.Nonce
+increment arg =
+  fromMaybe undefined
+    $  Nacl.decode
+    $  Serialize.encode w1'
+    <> Serialize.encode w2'
+    <> Serialize.encode w3'
+ where
+  noncebuf        = Nacl.encode arg
+  (b1, e3)        = BS.splitAt 16 noncebuf
+  (e1, e2)        = BS.splitAt 8 b1
+  w3              = fromRight undefined $ Serialize.decode e3 :: Word64
+  w2              = fromRight undefined $ Serialize.decode e2 :: Word64
+  w1              = fromRight undefined $ Serialize.decode e1 :: Word64
+  (w1', w2', w3') = inc (w1, w2, w3)
+
+
+-- | TODO: update me for handling multiple encryptions
+
+newConnState :: TCP.Socket -> SH.SharedSecrets -> Either Text ConnState
+newConnState socket sharedSecrets =
+  ConnState
+    <$> clientToServerKey sharedSecrets
+    <*> clientToServerNonce sharedSecrets
+    <*> serverToClientKey sharedSecrets
+    <*> serverToClientNonce sharedSecrets
+    <*> Right ""
+    <*> Right socket
+
+newServerConnState :: TCP.Socket -> SH.SharedSecrets -> Either Text ConnState
+newServerConnState socket sharedSecrets =
+  ConnState
+    <$> serverToClientKey sharedSecrets
+    <*> serverToClientNonce sharedSecrets
+    <*> clientToServerKey sharedSecrets
+    <*> clientToServerNonce sharedSecrets
+    <*> Right ""
+    <*> Right socket
+
+-- TODO: Fix underlying network functions
+--  Send never seems to fail.
+send :: ConnState -> ByteString -> IO (Either Text ())
+send state buf = runExceptT (TCP.send (socket state) buf)
+
+read :: ConnState -> Int -> IO (Maybe ByteString)
+read state 0     = return Nothing
+read state bytes = do
+  buf <- TCP.recv (socket state) bytes
+  case buf of
+    Nothing  -> return Nothing
+    Just buf ->
+      if BS.length buf == bytes
+        then return $ Just buf
+        else fmap (buf <>) <$> read state (bytes - BS.length buf)
+
+-- TODO: Keep connection terminology tied to peer and local.
+--    Using network terminology such as 'server' can be confusing in other when
+--    functions are used in other contexts.
+connectClient :: TCP.Socket -> SH.SharedSecrets -> IO (Either Text Conn)
+connectClient socket sharedSecrets = do
+  let state = newConnState socket sharedSecrets
+  case state of
+    Left  err   -> return $ Left err
+    Right state -> do
+      rstate <- newTMVarIO state
+      wstate <- newTMVarIO state
+      return . return $ Conn (rstate, wstate)
+
+connectServer :: TCP.Socket -> SH.SharedSecrets -> IO (Either Text Conn)
+connectServer socket sharedSecrets = do
+  let state = newServerConnState socket sharedSecrets
+  case state of
+    Left  err   -> return $ Left err
+    Right state -> do
+      rstate <- newTMVarIO state
+      wstate <- newTMVarIO state
+      return . return $ Conn (rstate, wstate)
+
+
+disconnect :: ConnState -> IO (Either Text ())
+disconnect connState = send connState $ goodBye connState
+
+-- TODO: Find out how to avoid these stair cases
+
+readStream'
+  :: ConnState -> Int -> IO (ConnState, Either Text (Maybe ByteString))
+readStream' connState bytes = if BS.length (buffer connState) >= bytes
+  then do
+    let (buf, rem) = BS.splitAt bytes (buffer connState)
+    let connState' = connState { buffer = rem }
+    return (connState', Right (Just buf))
+  else do
+    buf <- withErr errNoHeader <$> read connState headerLength
+    let header' = buf >>= decryptHeader key' nonce'
+    if header' == Right goodByeHeader
+        -- TODO: Error if not enough bytes available
+      then return (connState, return Nothing)
+      else do
+        let bodyLength' = bodyLength <$> (buf >>= decryptHeader key' nonce')
+        case bodyLength' of
+          Left  err         -> return $ (connState, Left err)
+          Right bodyLength' -> do
+            ePayload <- (withErr errNoBody)
+              <$> read connState (fromIntegral bodyLength')
+            case ePayload of
+              Left err -> return $ (connState, Left err)
+              Right payload ->
+                case
+                    decryptMessage key'
+                                   nonce'
+                                   (fromRight undefined buf <> payload)
+                  of
+                    Left  err     -> return (connState, Left err)
+                    Right payload -> readStream'
+                      (updateNonce . appendBuffer payload $ connState)
+                      bytes
+ where
+  errNoHeader = "could not read header"
+  errNoBody   = "could not read body"
+  key'        = remoteKey connState
+  nonce'      = remoteNonce connState
+  updateNonce connState =
+    connState { remoteNonce = (increment . increment) (remoteNonce connState) }
+  appendBuffer buf connState = connState { buffer = buffer connState <> buf }
+
+readStream :: Conn -> Int -> IO (Either Text (Maybe ByteString))
+readStream (Conn (mVar, _)) bytes = do
+  state         <- atomically $ takeTMVar mVar
+  (state', ret) <- readStream' state bytes
+  atomically $ putTMVar mVar state'
+  return ret
+
+sendStream' :: ConnState -> ByteString -> IO (ConnState, Either Text ())
+sendStream' connState msg = do
+  let eMsg = encryptMessage key' nonce' msg
+  case eMsg of
+    Left  err -> return (connState, Left err)
+    Right buf -> do
+      ret <- send connState buf
+      return (updateNonce connState, ret)
+ where
+  key'   = key connState
+  nonce' = nonce connState
+  updateNonce connState =
+    connState { nonce = (increment . increment) (nonce connState) }
+
+sendStream :: Conn -> ByteString -> IO (Either Text ())
+sendStream (Conn (_, mVar)) buf = do
+  state         <- atomically $ takeTMVar mVar
+  (state', ret) <- sendStream' state buf
+  atomically $ putTMVar mVar state'
+  return ret
+
+-- | authTagLength is the AuthTag size in bytes
+authTagLength = 16
+
+newtype AuthTag = AuthTag ByteString
+  deriving (Eq,Generic,Show)
+
+instance Serialize.Serialize AuthTag where
+  get = AuthTag <$> Serialize.getByteString authTagLength
+  put (AuthTag buf) = Serialize.putByteString buf
+
+extractAuthTag :: AuthTag -> ByteString
+extractAuthTag (AuthTag buf) = buf
+
+-- | Aux functions
+takeMay :: Int -> ByteString -> Maybe ByteString
+takeMay l arg = if BS.length arg <= l then return $ BS.take l arg else Nothing
diff --git a/src/Ssb/Peer/RPC.hs b/src/Ssb/Peer/RPC.hs
new file mode 100644
index 0000000..e5a4c9a
--- /dev/null
+++ b/src/Ssb/Peer/RPC.hs
@@ -0,0 +1,859 @@
+-- For more information kindly refer the to protocol guide
+-- https://ssbc.github.io/scuttlebutt-protocol-guide
+
+module Ssb.Peer.RPC where
+
+import           Protolude
+
+import           Control.Concurrent.STM
+import           Control.Monad.Fail
+import           Data.Aeson                     ( FromJSON
+                                                , ToJSON
+                                                )
+import           Data.Aeson                    as Aeson
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as BS
+                                                ( toStrict )
+import qualified Data.Map.Strict               as Map
+import           Data.Default
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import           Data.Text                     as Text
+import           Data.Serialize                as Serialize
+
+import           Ssb.Aux
+import qualified Ssb.Identity                  as Ssb
+import qualified Ssb.Peer.BoxStream            as BoxStream
+
+data BodyType = Binary | UTF8String | JSON | UnknownBodyType
+    deriving (Bounded,Eq,Show)
+
+instance Convertible Word8 BodyType where
+  convert v = case v .&. 3 of
+    0 -> Binary
+    1 -> UTF8String
+    2 -> JSON
+    v -> UnknownBodyType
+
+instance Convertible BodyType Word8 where
+  convert Binary          = 0
+  convert UTF8String      = 1
+  convert JSON            = 2
+  convert UnknownBodyType = 3
+
+data Flags = Flags
+    { unused1      :: Bool
+    , unused2      :: Bool
+    , unused3      :: Bool
+    , unused4      :: Bool
+    , isStream     :: Bool
+    , isEndOrError :: Bool
+    , bodyType     :: BodyType
+    } deriving (Eq,Show)
+
+instance Convertible Flags Word8 where
+  convert arg =
+    set (unused1 arg) 7
+      $ set (unused2 arg)      6
+      $ set (unused3 arg)      5
+      $ set (unused4 arg)      4
+      $ set (isStream arg)     3
+      $ set (isEndOrError arg) 2
+      $ convert (bodyType arg)
+   where
+    set True  pos arg = setBit arg pos
+    set False _   arg = arg
+
+instance Convertible Word8 Flags where
+  convert w = Flags { unused1      = testBit w 7
+                    , unused2      = testBit w 6
+                    , unused3      = testBit w 5
+                    , unused4      = testBit w 4
+                    , isStream     = testBit w 3
+                    , isEndOrError = testBit w 2
+                    , bodyType     = convert w
+                    }
+
+instance Default Flags where
+  def = convert (zeroBits :: Word8)
+
+instance Serialize.Serialize Flags where
+  get = convert <$> getWord8
+  put = putWord8 . convert
+
+-- | ProcedureType defines the type of remote call.
+data ProcedureType =  Async | Source | Duplex
+    deriving (Eq,Generic,Ord,Show)
+
+instance FromJSON ProcedureType where
+  parseJSON = withText "ProcedureType" $ \v -> case v of
+    "async"   -> return Async
+    "source"  -> return Source
+    "duplex"  -> return Duplex
+    otherwise -> fail $ "unknown value '" <> toS v <> "'"
+
+instance ToJSON ProcedureType where
+  toJSON Async  = "async"
+  toJSON Source = "source"
+  toJSON Duplex = "duplex"
+
+-- | HeaderLength is the length of the RPC header in bytes
+headerLength :: Int
+headerLength = 9
+
+-- | bodySizeLength is the length of the bodySize parameter in the RPC header.
+bodySizeLength :: Int
+bodySizeLength = 4
+
+-- | requestNumberLength is the length of the requestNumberLength parameter in
+-- the RPC header.
+requestNumberLength :: Int
+requestNumberLength = 4
+
+-- | Header is the first part of a RPC message used for stream control and communication.
+data Header = Header
+    { flags         :: Flags
+    , bodyLength    :: Word32
+    , requestNumber :: Int32
+    } deriving (Eq,Generic,Show)
+
+instance Serialize.Serialize Header
+
+-- | GoodByeHeader is the RPC message header signalling the end of the RPC
+-- stream.
+goodByeHeader :: Header
+goodByeHeader = Header (convert (zeroBits :: Word8)) 0 0
+
+newHeader :: Flags -> Int32 -> ByteString -> Either Text Header
+newHeader flags reqNum body = do
+  let bodyLength = fromIntegral $ BS.length body
+  return Header { flags         = flags
+                , bodyLength    = bodyLength
+                , requestNumber = reqNum
+                }
+
+-- | MessagePayload describes and contains the contents of an RPC message.
+data MessagePayload = BinaryPayload ByteString | TextPayload ByteString | JSONPayload ByteString
+    deriving (Generic,Show)
+
+-- | Message is a single message in the RPC stream
+data Message = Message
+    { header :: Header
+    , body   :: MessagePayload
+    } deriving (Generic,Show)
+
+instance Serialize.Serialize Message where
+  get = do
+    header <- Serialize.get
+    buf    <- Serialize.getByteString (fromIntegral $ bodyLength header)
+    let typ = bodyType . flags $ header
+    payload <- case typ of
+      Binary          -> return $ BinaryPayload buf
+      UTF8String      -> return $ TextPayload buf
+      JSON            -> return $ JSONPayload buf
+      UnknownBodyType -> fail "unknown body type"
+    return $ Message header payload
+
+  put msg = do
+    Serialize.put (header msg)
+    case body msg of
+      BinaryPayload buf -> Serialize.putByteString buf
+      JSONPayload   buf -> Serialize.putByteString buf
+      TextPayload   buf -> Serialize.putByteString buf
+
+-- | newJSONMessage is a convenience function to create a RPC message with a
+-- JSON payload.
+newJSONMessage :: ToJSON a => Int32 -> a -> Either Text Message
+newJSONMessage reqNum payload = do
+  let buf = BS.toStrict $ Aeson.encode payload
+  len     <- maybeWord8 $ BS.length buf
+  header' <- newHeader (def { bodyType = JSON }) reqNum buf
+  return $ Message { header = header', body = JSONPayload buf }
+
+-- | newJSONMessage is a convenience function to decode a RPC JSON message.
+decodeJSONMessage :: FromJSON a => Message -> Either Text a
+decodeJSONMessage msg = case body msg of
+  JSONPayload buf -> decodeJSON buf
+  _               -> error "unexpected body type"
+
+isRequest :: Int32 -> Message -> Bool
+isRequest nextReqNum msg = do
+  let reqNum = requestNumber . header $ msg
+  nextReqNum == reqNum
+
+-- | Request is the message representing a RPC call.
+data Request a = Request
+    { name :: [Text]
+    , typ  :: ProcedureType
+    , args :: a
+    } deriving (Show)
+
+instance (FromJSON a) => FromJSON (Request a) where
+  parseJSON = withObject "Request"
+    $ \v -> Request <$> v .: "name" <*> v .:? "type" .!= Async <*> v .: "args"
+
+instance (ToJSON a) => ToJSON (Request a) where
+  toJSON arg =
+    object ["name" .= name arg, "type" .= typ arg, "args" .= args arg]
+
+data Direction = Incoming | Outgoing
+    deriving (Eq,Generic,Show)
+
+data StreamStatus =
+      -- | Open the stream is active.
+      Open
+      -- | The (Async) stream is awaiting a response.
+    | AwaitingResponse
+      -- | The stream is closed and waiting for its peer to do the same.
+    | AwaitingCloseRecv
+      -- | The stream is closed.
+    | Closed
+    deriving (Eq,Show)
+
+data Stream  = Stream {
+      streamID    :: Int32
+    , streamType  :: ProcedureType
+    , conn        :: ConnState
+    , direction   :: Direction
+    , status      :: StreamStatus
+    , peer        :: Ssb.PublicKey
+    }
+
+formatStream :: Stream -> Text
+formatStream stream =
+  (show $ streamID stream :: Text)
+    <> "\t"
+    <> show (streamType stream)
+    <> "\t"
+    <> show (direction stream)
+    <> "\t"
+    <> show (status stream)
+
+foldStream
+  :: (a -> MessagePayload -> IO (Either Text a))
+  -> a
+  -> Stream
+  -> IO (Either Text a)
+foldStream fn acc stream = do
+  msg <- readStream stream
+  case msg of
+    (Just msg') -> do
+      acc' <- fn acc msg'
+      either (return . error) (\v -> foldStream fn v stream) acc'
+    Nothing -> return . return $ acc
+
+foldJSONStream
+  :: (FromJSON b)
+  => (a -> b -> IO (Either Text a))
+  -> a
+  -> Stream
+  -> IO (Either Text a)
+foldJSONStream fn acc stream = do
+  msg <- readStreamJSON stream
+  case msg of
+    (Right (Just msg')) -> do
+      acc' <- fn acc msg'
+      either (return . error) (\v -> foldJSONStream fn v stream) acc'
+    (Right Nothing) -> return . return $ acc
+    (Left  err    ) -> return $ error err
+
+data ConnState = ConnState {
+    connPeer           :: Ssb.PublicKey
+  , boxConn            :: BoxStream.Conn
+  , streamsIn          :: TMVar (Map Int32 (Stream, TChan (Maybe Message)))
+  , streamsOut         :: TMVar (Map Int32 (Stream, TChan (Maybe Message)))
+  , nextIncomingReqNum :: TMVar Int32
+  , nextOutgoingReqNum :: TMVar Int32
+  , lock               :: TMVar Bool
+  }
+
+-- | Endpoint identifies which Remote Procedure Call to make.
+data Endpoint = Endpoint [Text] ProcedureType
+  deriving (Eq, Ord)
+
+formatEndpoint :: Endpoint -> Text
+formatEndpoint (Endpoint paths typ) =
+  Text.intercalate "." paths <> ":" <> show typ
+
+-- | HandlerFunc's are used to serve Remove Procedure Calls.
+type HandlerFunc = Aeson.Value -> Stream -> IO (Either Text ())
+
+-- | notFoundHandlerFunc is tells the peer the Endpoint does not exist.
+notFoundHandlerFunc :: Endpoint -> HandlerFunc
+notFoundHandlerFunc endpoint _ _ = return
+  (Left $ "endpoint not found '" <> endpoint' <> "'")
+  where endpoint' = formatEndpoint endpoint
+
+-- | Handler can serve Remote Procedure Requests.
+class Handler h  where
+    endpoints
+        :: h
+        -> [Endpoint]
+
+    -- | Serve calls an incoming Remote Procedure Call.
+    serve
+        :: h
+        -> Endpoint
+        -> HandlerFunc
+
+    -- TODO: Maybe add 'conn' to notifyConnect
+
+    -- | notifyConnect tells the handler when a peer has connected.
+    notifyConnect
+        :: h
+        -> Ssb.PublicKey
+        -> IO (Either Text ())
+
+    -- | notifyDisconnect tells the handler when a peer has disconnected.
+    notifyDisconnect
+        :: h
+        -> Ssb.PublicKey
+        -> IO (Either Text ())
+
+-- | Router serves Remote Procedure Calls with a set of handlers.
+data Router = Router {
+      endpointHandlers :: Map Endpoint HandlerFunc
+    , connectCallbacks :: [Ssb.PublicKey -> IO (Either Text ())]
+    , disconnectCallbacks :: [Ssb.PublicKey -> IO (Either Text ())]
+    } deriving (Generic)
+
+instance Default Router
+
+instance Handler Router where
+  endpoints demuxer = Map.keys (endpointHandlers demuxer)
+
+  serve demuxer endpoint = case Map.lookup endpoint endpointHandlers' of
+    Nothing      -> (notFoundHandlerFunc endpoint)
+    Just handler -> handler
+    where endpointHandlers' = endpointHandlers demuxer
+
+  notifyConnect demuxer id = do
+    errs <- fmap lefts . sequence $ (\f -> f id) <$> connectCallbacks demuxer
+    if Protolude.null errs
+      then return . return $ ()
+      else return $ Left $ Text.intercalate ", " errs
+
+  notifyDisconnect demuxer id = do
+    errs <- fmap lefts . sequence $ (\f -> f id) <$> connectCallbacks demuxer
+    if Protolude.null errs
+      then return . return $ ()
+      else return $ Left $ Text.intercalate ", " errs
+
+
+-- | with adds a handler to the Router.
+with :: Handler h => Router -> h -> Router
+with demuxer handler = Router
+  { endpointHandlers    = Map.union (endpointHandlers demuxer) $ Map.fromList
+                            ((\e -> (e, serve handler e)) <$> endpoints handler)
+  , connectCallbacks    = connectCallbacks demuxer <> [notifyConnect handler]
+  , disconnectCallbacks = disconnectCallbacks demuxer
+                            <> [notifyDisconnect handler]
+  }
+
+-- | withM is a convenience function for using 'with' in monads.
+withM :: (MonadIO m, Handler h) => m Router -> m h -> m Router
+withM demuxer handler = with <$> demuxer <*> handler
+
+logMsg :: ConnState -> Text -> IO ()
+logMsg conn msg = do
+  _ <- atomically $ takeTMVar (lock conn)
+  print msg
+  atomically $ putTMVar (lock conn) True
+
+logDebug :: ConnState -> Text -> IO ()
+logDebug _ _ = return ()
+-- logDebug = logMsg
+
+-- | spawnConnection handles safely forking and closing RPC connections.
+spawnConnection
+  :: Stream
+  -> IO (Either Text ())
+  -> IO ()
+spawnConnection stream action = do
+  forkFinally
+    (do
+      res <- action
+      either (closeStreamWithError stream) (\_ -> closeStream stream) res
+    )
+    (\_ -> void (closeStream stream))
+  return ()
+
+-- | connect creates a Remote Procdure Call stream connection over the give Box
+-- Stream.
+connect
+  :: Handler h
+  => BoxStream.Conn
+  -> h
+  -> Ssb.PublicKey
+  -> (ConnState -> IO ())
+  -> IO (Either Text ())
+connect boxConn handler peer client = do
+  streamsIn          <- newTMVarIO Map.empty
+  streamsOut         <- newTMVarIO Map.empty
+  nextIncomingReqNum <- newTMVarIO 1
+  nextOutgoingReqNum <- newTMVarIO 1
+  lock               <- newTMVarIO True
+  let conn = ConnState { connPeer           = peer
+                       , boxConn            = boxConn
+                       , streamsIn          = streamsIn
+                       , streamsOut         = streamsOut
+                       , nextIncomingReqNum = nextIncomingReqNum
+                       , nextOutgoingReqNum = nextOutgoingReqNum
+                       , lock               = lock
+                       }
+
+  forkIO $
+    -- make RPC calls on the peer
+           client conn
+  print "entering service loop"
+  ret <- serviceLoop conn
+  print "out of service loop"
+  _   <- notifyDisconnect handler (connPeer conn)
+  print "disconnecting"
+  disconnect conn
+  print "disconnected"
+  return ret
+ where
+  serviceLoop conn = do
+    msg <- readMessage conn
+    case msg of
+      Left  err -> return $ error ("connection error: " <> err)
+      Right msg -> if header msg == goodByeHeader
+        then return . return $ ()
+        else do
+          ok <- handleMessage handler conn msg
+          if ok then serviceLoop conn else return . return $ ()
+
+-- TODO: Handle stream closing within demux loop
+--    The handleMessage loop is responsible for the lifetime of a stream
+--    connection.  It detects and creates requests, it should therefor handle
+--    close requests.
+--
+--    The stream type matters when closing a stream. Async do not require a
+--    specific close message.
+-- TODO: Handle closing of Async streams
+-- TODO: Properly handle Error message
+
+-- TODO: Refactor or reallocate helper functions
+--    These functions were added in a rush to get request handling working.  A
+--    better place could probably be found for them to improve code clarity.
+
+-- | isEndOfStream checks whether the message is the last of the stream.
+isEndOfStream = isEndOrError . flags . header
+
+-- | checks if the message is a response to an Async request.
+isAsyncResponse = not . isStream . flags . header
+
+-- | streamTable gets which lookup table to use for connections for the given
+-- stream.  There are seperate ones for incoming and outgoing RPC streams.
+streamTable stream = case direction stream of
+  Incoming -> streamsIn (conn stream)
+  Outgoing -> streamsOut (conn stream)
+
+streamStatus :: Stream -> STM StreamStatus
+streamStatus stream = do
+  table <- readTMVar $ streamTable stream
+  return
+    $ fromMaybe Closed (status . fst <$> Map.lookup (streamID stream) table)
+
+-- | manageStreamConn manages stream connection changes when writing messages
+-- to a stream.
+-- TODO: beware of entering a deadlock in manageStreamConn
+-- TODO: request stuff should be moved here
+manageStreamConn :: Stream -> Message -> IO (Either Text ())
+manageStreamConn stream msg = do
+  table <- atomically $ takeTMVar $ streamTable stream
+  res   <- writeMessage (conn stream) msg
+  let table' = if
+        | isLeft res -> closeStream table stream
+        | (not . isStream . flags . header $ msg) -> Map.adjust
+          (updateStreamStatus AwaitingResponse)
+          (streamID stream)
+          table
+        |
+-- TODO: confirm status of stream before closing it
+-- This happy path is not production ready
+          (isEndOrError . flags . header $ msg) -> Map.adjust
+          (updateStreamStatus AwaitingCloseRecv)
+          (streamID stream)
+          table
+        | otherwise -> table
+  when (isLeft res) $ do
+    let (_, c) = fromMaybe undefined $ Map.lookup (streamID stream) table
+    -- TODO: Find better way of closing channels on write error
+    atomically $ forM_ [1 .. 30] (\_ -> writeTChan c Nothing)
+  atomically $ putTMVar (streamTable stream) table'
+  return res
+ where
+  updateStreamStatus status (s, c) = (s { status = status }, c)
+  closeStream table tream = case direction stream of
+    Incoming -> Map.adjust (updateStreamStatus Closed) (streamID stream) table
+    Outgoing -> Map.delete (streamID stream) table
+
+
+-- TODO: Log important information for incoming messages
+handleMessage :: Handler h => h -> ConnState -> Message -> IO Bool
+handleMessage handler conn msg = do
+  nextReqNum <- atomically $ readTMVar (nextIncomingReqNum conn)
+  if
+    | (header msg) == goodByeHeader -> return False
+    | (isRequest nextReqNum msg) -> serveRequest handler conn msg
+    | (isEndOfStream msg) -> internalCloseStream conn msg
+    | (isAsyncResponse msg) -> do
+      demux conn msg
+      internalCloseStream conn msg
+    | otherwise -> demux conn msg
+ where
+  internalCloseStream conn msg = do
+    let flags          = def { isStream = True, isEndOrError = True }
+    let requestNumber' = (requestNumber . header $ msg)
+    let mVarTable =
+          if requestNumber' > 0 then streamsIn conn else streamsOut conn
+    table <- atomically $ takeTMVar mVarTable
+    let streamID'      = abs requestNumber'
+    let (stream, chan) = fromMaybe undefined $ Map.lookup streamID' table
+    newStatus <- case status stream of
+      Open -> do
+        let msg = fromRight undefined $ newCloseNotification streamID'
+        _ <- writeMessage conn msg
+        return AwaitingCloseRecv
+      AwaitingCloseRecv -> do
+        atomically $ writeTChan chan Nothing
+        return Closed
+      AwaitingResponse -> do
+        atomically $ writeTChan chan Nothing
+        return Closed
+      Closed -> do
+        logMsg conn
+          $  "received end of stream for already closed stream: "
+          <> (show streamID' :: Text)
+        return Closed
+    atomically $ putTMVar mVarTable $ case direction stream of
+      Incoming -> Map.adjust (updateStreamStatus newStatus) streamID' table
+      -- TODO: properly handle close of outgoing Duplex streams
+      Outgoing -> Map.delete streamID' table
+    return True
+    where updateStreamStatus status (s, c) = (s { status = status }, c)
+
+  serveRequest handler conn msg = do
+    let req = decodeJSONMessage msg
+    case req of
+      Left err -> do
+        logMsg conn $ "could not decode request: " <> err
+        return False
+      Right req -> do
+        let stream = Stream { streamID   = requestNumber . header $ msg
+                            , streamType = typ req
+                            , conn       = conn
+                            , direction  = Incoming
+                            , status     = Open
+                            , peer       = connPeer conn
+                            }
+        chan <- newTChanIO
+        err  <- atomically $ do
+          reqNum <- takeTMVar (nextIncomingReqNum conn)
+          table  <- takeTMVar (streamsIn conn)
+          if Map.size table == (maxBound :: Int)
+            then return $ Left errTooManyRequests
+            else do
+              let (reqNum', table') = if streamID stream == reqNum
+                    then (reqNum + 1, (Map.insert reqNum (stream, chan) table))
+                    else (reqNum, table)
+              putTMVar (nextIncomingReqNum conn) reqNum'
+              putTMVar (streamsIn conn)          table'
+              return . return $ ()
+        case err of
+          Left msg -> do
+            print msg
+            return False
+          Right _ -> do
+            -- Serving a request call, how do we close it nicely?
+            let endpoint = Endpoint (name req) (typ req)
+            spawnConnection stream $ (serve handler) endpoint (args req) stream
+            return True
+    where errTooManyRequests = "connection limit reached, dropping request"
+
+  demux conn msg = do
+    let reqNum    = requestNumber . header $ msg
+    let table = if reqNum > 0 then streamsIn conn else streamsOut conn
+    let streamID' = abs reqNum
+    table' <- atomically $ readTMVar table
+    case Map.lookup streamID' table' of
+      Nothing -> do
+        logDebug conn
+          $  "message dropped due to missing stream: "
+          <> (show msg :: Text)
+        return ()
+      Just (_, chan) -> atomically $ writeTChan chan (Just msg)
+    return True
+
+-- | disconnect is a hacked version, it rudely disconnects all connections in
+-- order to unlock streams stuck on their reading their channels.
+--
+-- Look into closing streams elegantly.
+-- TODO: Ensure disconnect prevents new incoming and outgoing connections
+disconnect :: ConnState -> IO ()
+disconnect conn = do
+  table <- atomically $ takeTMVar (streamsIn conn)
+  forM_ table
+    $ \(_, c) -> atomically $ forM_ [1 .. 30] (\_ -> writeTChan c Nothing)
+  let table' = Map.map (\(s, c) -> (s { status = Closed }, c)) table
+  atomically $ putTMVar (streamsIn conn) table'
+
+  table <- atomically $ takeTMVar (streamsOut conn)
+  forM_ table
+    $ \(_, c) -> atomically $ forM_ [1 .. 30] (\_ -> writeTChan c Nothing)
+  let table' = Map.map (\(s, c) -> (s { status = Closed }, c)) table
+  atomically $ putTMVar (streamsOut conn) table'
+
+  _ <- writeMessage conn $ Message goodByeHeader (BinaryPayload "")
+  return ()
+
+-- | readBoxStream reads the given number of bytes from the Box Stream.
+readBoxStream :: BoxStream.Conn -> Int -> IO (Either Text ByteString)
+readBoxStream conn bytes = do
+  mbuf <- BoxStream.readStream conn bytes
+  let buf = join $ (maybeToRight errUnexpectedClose) <$> mbuf
+  return buf
+  where errUnexpectedClose = "rpc.readConn: unexpected end of box stream"
+
+
+-- | readMessage reads a single message from the RPC connection.
+readMessage :: ConnState -> IO (Either Text Message)
+readMessage conn = do
+  headerBuf <- readBoxStream (boxConn conn) headerLength
+  header    <- (return $ headerBuf >>= decode)
+  case header of
+    Left  err    -> return $ Left $ "RPC.readMessage header: " <> err
+    Right header -> do
+      bodyBuf <- readBoxStream (boxConn conn) (fromIntegral $ bodyLength header)
+      let ret = liftA2 (<>) headerBuf bodyBuf >>= decode
+      logDebug conn
+        $  "readMessage ("
+        <> (Ssb.formatPublicKey $ connPeer conn)
+        <> ")"
+        <> (show ret)
+      return $ ret
+ where
+  decode :: Serialize a => ByteString -> Either Text a
+  decode = mapLeft toS . Serialize.decode
+
+writeMessage :: ConnState -> Message -> IO (Either Text ())
+writeMessage conn msg = do
+  logDebug conn
+    $  "writeMessage ("
+    <> (Ssb.formatPublicKey $ connPeer conn)
+    <> ")"
+    <> (show msg)
+  BoxStream.sendStream (boxConn conn) $ Serialize.encode msg
+
+-- | request makes a Remote Procedure Call on the peer.
+request
+  :: ToJSON a
+  => ConnState
+  -> Request a
+  -> (Stream -> IO (Either Text b))
+  -> IO (Either Text b)
+request conn req session = do
+  reqNum <- atomically $ takeTMVar (nextOutgoingReqNum conn)
+  let msg = newJSONMessage reqNum req
+  case msg of
+    Left err -> do
+      atomically $ putTMVar (nextOutgoingReqNum conn) reqNum
+      return $ Left err
+    Right msg -> do
+      let nextReqNum = reqNum + 1
+      atomically $ putTMVar (nextOutgoingReqNum conn) nextReqNum
+
+      -- TODO: Fix late night update
+      let flags' = flags . header $ msg
+      let
+        msg' = msg
+          { header = (header msg) { flags = flags'
+                                    { isStream = typ req /= Async
+                                    }
+                                  }
+          }
+
+      let stream = Stream { streamID   = reqNum
+                          , streamType = (typ req)
+                          , conn       = conn
+                          , direction  = Outgoing
+                          , status     = Open
+                          , peer       = connPeer conn
+                          }
+      atomically $ do
+        streams <- takeTMVar (streamsOut conn)
+        chan    <- newTChan
+        putTMVar (streamsOut conn) $ Map.insert reqNum (stream, chan) streams
+
+      _      <- writeMessage' stream msg'
+      result <- session stream
+      if streamType stream == Async
+        then return . return $ ()
+        else either (closeStreamWithError stream)
+                    (\x -> closeStream stream)
+                    result
+      return result
+  where writeMessage' = manageStreamConn
+
+-- | requestAsync is the Async version of request.
+requestAsync
+  :: (ToJSON a, FromJSON b) => ConnState -> Request a -> IO (Either Text b)
+requestAsync conn req = do
+  resp <- request conn req readStreamJSON
+  return $ resp >>= withErr "not response received"
+
+-- TODO: Use CloseNotification to signal close of stream.
+--   How is the JSON encoding done?
+data CloseNotification = CloseNotification ()
+
+newCloseNotification :: Int32 -> Either Text Message
+newCloseNotification streamID = do
+  let payload      = JSONPayload "true"
+  let requestNumer = -1 * streamID
+  header <- newHeader
+    (def { isEndOrError = True, isStream = True, bodyType = JSON })
+    requestNumer
+    "true"
+  return $ Message header payload
+
+-- | closeStream politely shuts down an RPC stream.
+-- TODO: closeStream needs to be more adaptive.  It only accounts for
+-- real streams.
+closeStream :: Stream -> IO (Either Text ())
+closeStream stream = case (status stream, streamType stream) of
+  (_   , Async) -> return . return $ ()
+  (Open, _    ) -> either (return . Left) (manageStreamConn stream)
+    $ newCloseNotification (streamID stream)
+  (Closed, _) -> return . return $ ()
+  (_     , _) -> return $ Left "could not close stream"
+
+-- ErrorNotification is the format used to communicate a stream error between peers.
+data ErrorNotification = ErrorNotification {
+      message :: Text
+    , stack   :: Maybe Text
+    }
+
+instance FromJSON ErrorNotification where
+  parseJSON = withObject "Error"
+    $ \v -> ErrorNotification <$> v .: "message" <*> v .: "stack"
+
+instance ToJSON ErrorNotification where
+  toJSON arg = object
+    [ "name" .= ("error" :: Text)
+    , "message" .= message arg
+    , "stack" .= stack arg
+    ]
+
+-- TODO: deduplicate closeStreamWithError and closeStream code
+-- TODO: Verify close operation on error
+--    Does the remote end send an 'true' message to confirm?  Or is the
+--    connection simply dropped.
+closeStreamWithError' :: Stream -> Text -> IO (Either Text ())
+closeStreamWithError' stream err = do
+  if streamType stream == Duplex || direction stream == Incoming
+    then do
+      let msg   = ErrorNotification err Nothing
+      let flags = def { isStream = True, isEndOrError = True }
+      err <- writeStream stream
+                         flags
+                         (JSONPayload $ BS.toStrict $ Aeson.encode msg)
+      either
+        (\err ->
+          logMsg (conn stream) $ "could not notify remote of error: " <> err
+        )
+        return
+        err
+    else logMsg (conn stream) $ "closing stream with error: " <> err
+  atomically $ do
+    let table = streamTable stream
+    value <- takeTMVar table
+    putTMVar table $ Map.delete (streamID stream) value
+  return . return $ ()
+ where
+  streamTable stream = case direction stream of
+    Incoming -> streamsIn $ conn stream
+    Outgoing -> streamsOut $ conn stream
+
+-- TODO: Merge newCloseErrorNotification with newCloseNotification It has
+-- proven difficult to use the ToJSON typeclass as an argument.
+newCloseErrorNotification :: Int32 -> Text -> Either Text Message
+newCloseErrorNotification streamID msg = do
+  let payload = JSONPayload $ BS.toStrict $ Aeson.encode msg
+  let requestNumer = -1 * streamID
+  header <- newHeader
+    (def { isEndOrError = True, isStream = True, bodyType = JSON })
+    requestNumer
+    "true"
+  return $ Message header payload
+
+closeStreamWithError :: Stream -> Text -> IO (Either Text ())
+closeStreamWithError stream err = case streamType stream of
+  Async -> return . return $ ()
+  otherwise ->
+    either (return . Left) (manageStreamConn stream)
+      $ newCloseErrorNotification (streamID stream) err
+
+-- TODO: Properly translate RPC errors
+-- TODO: Close stream within lock to avoid race conditions
+
+readStream :: Stream -> IO (Maybe MessagePayload)
+readStream stream = do
+  let table = streamTable stream
+  table' <- atomically $ readTMVar table
+  let result = Map.lookup (streamID stream) table'
+  msg <- case result of
+    Nothing               -> return Nothing
+    Just (stream', chan') -> if status stream' == Closed
+      then atomically $ join <$> tryReadTChan chan'
+      else atomically $ readTChan chan'
+  table'' <- atomically $ takeTMVar table
+  let table''' = case msg of
+        Nothing -> Map.delete (streamID stream) table'
+        Just _  -> table''
+  atomically $ putTMVar table table'''
+  return (body <$> msg)
+
+-- | readStreamJSON reads a single JSON message from the RPC stream.
+readStreamJSON :: FromJSON a => Stream -> IO (Either Text (Maybe a))
+readStreamJSON stream = do
+  resp <- readStream stream
+  case resp of
+    (Just (JSONPayload buf)) -> return (Just <$> decodeJSON buf)
+    (Just otherwise        ) -> return (errPayload resp)
+    Nothing                  -> return . return $ Nothing
+ where
+  errPayload payload =
+    error ("expected JSONPayload but got " <> (show payload :: Text))
+  errEOS = error "end of stream"
+
+writeStream :: Stream -> Flags -> MessagePayload -> IO (Either Text ())
+writeStream stream flags payload = do
+  status <- atomically $ streamStatus stream
+  if status /= Open
+    then return $ Left "stream closed"
+    else do
+      let msgID = case direction stream of
+            Incoming -> -1 * streamID stream
+            Outgoing -> streamID stream
+      let flags' = flags { isStream = not $ (streamType stream) == Async }
+      let header' = case payload of
+            (BinaryPayload p) ->
+              newHeader (flags' { bodyType = Binary }) msgID p
+            (TextPayload p) ->
+              newHeader (flags' { bodyType = UTF8String }) msgID p
+            (JSONPayload p) -> newHeader (flags' { bodyType = JSON }) msgID p
+      case header' of
+        Left  err     -> return $ Left err
+        Right header' -> do
+          let msg = Message header' payload
+          writeMessage' stream msg
+  where writeMessage' = manageStreamConn
+
+-- | writeStreamJSON writes a single JSON message to the RPC stream.
+writeStreamJSON :: ToJSON a => Stream -> a -> IO (Either Text ())
+writeStreamJSON stream msg = do
+  let buf = Aeson.encode msg
+  writeStream stream def (JSONPayload $ BS.toStrict buf)
diff --git a/src/Ssb/Peer/RPC/Gossip.hs b/src/Ssb/Peer/RPC/Gossip.hs
new file mode 100644
index 0000000..b97e4a4
--- /dev/null
+++ b/src/Ssb/Peer/RPC/Gossip.hs
@@ -0,0 +1,139 @@
+-- | This module implements Scuttlebutt's Remote Procedure Call for
+-- CreateHistoryStream.
+--
+-- For more information kindly refer the to protocol guide
+-- https://ssbc.github.io/scuttlebutt-protocol-guide
+
+module Ssb.Peer.RPC.Gossip where
+
+import           Protolude               hiding ( Identity )
+
+import           Control.Concurrent.STM
+import qualified Data.Aeson                     as Aeson
+import           Data.Aeson                     ( FromJSON
+                                                , ToJSON
+                                                )
+import           Data.Default
+import qualified Data.Map.Strict               as Map
+
+import           Ssb.Aux
+import qualified Ssb.Feed                      as Feed
+import qualified Ssb.Peer.RPC                  as RPC
+
+
+-- | TODO: Comment
+-- | TODO: Naming
+-- | TODO: Keyed Message support
+-- | TODO: Proper Request default values setting
+data Request = Request
+    { id        :: Feed.FeedID
+    , sequence  :: Maybe Int
+    , limit     :: Maybe Int
+    , live      :: Maybe Bool
+    , old       :: Maybe Bool
+    , keys      :: Bool
+    } deriving (Generic,Show)
+
+newRequest :: Feed.FeedID -> Request
+newRequest id = Request { id       = id
+                        , sequence = Nothing
+                        , limit    = Nothing
+                        , live     = Just False
+                        , old      = Just False
+                        , keys     = True
+                        }
+
+
+instance FromJSON Request
+
+instance ToJSON Request where
+  toJSON = Aeson.genericToJSON (Aeson.defaultOptions {Aeson.omitNothingFields = True})
+
+-- TODO: reduce friction for introducing RPC requests
+
+createHistoryStreamRequest :: Request -> RPC.Request [Request]
+createHistoryStreamRequest req = RPC.Request
+  { RPC.name = ["createHistoryStream"]
+  , RPC.typ  = RPC.Source
+  , RPC.args = [req]
+  }
+
+createHistoryStream
+  :: FromJSON b
+  => RPC.ConnState
+  -> Request
+  -> a
+  -> (a -> Feed.VerifiableMessage b -> IO (Either Text a))
+  -> IO (Either Text a)
+createHistoryStream conn req init cmd = RPC.request
+  conn
+  (createHistoryStreamRequest req)
+  (RPC.foldStream cmd' init)
+ where
+  cmd' a payload = case payload of
+    RPC.JSONPayload buf -> do
+      msg <- Feed.decodeJSONVerifiableMessage buf
+      either (return . error) (cmd a) msg
+    v@otherwise -> return $ error "expected JSON but got something else"
+
+data KeyedMessage a = KeyedMessage
+  { key       :: Feed.MessageID
+  , timestamp :: Int
+  , value     :: Feed.Message a
+  } deriving (Generic,Show)
+
+instance (FromJSON a) => FromJSON (KeyedMessage a)
+
+instance (ToJSON a) => ToJSON (KeyedMessage a)
+
+--createKeyedHistoryStream
+--  :: RPC.ConnState
+--  -> Request
+--  -> (KeyedMessage -> IO (Either Text a))
+--  -> IO (Either Text a)
+--createHistoryStream conn req =
+--  RPC.request conn (createHistoryStreamRequest req)
+--
+
+newtype Gossiper a = Gossiper (TMVar (Feed.Feeds a))
+
+newGossiper :: ToJSON a => IO (Gossiper a)
+newGossiper = do
+    mVar <- newTMVarIO Feed.emptyFeeds
+    return $ Gossiper mVar
+
+addFeed :: ToJSON a => Gossiper a -> Feed.Feed a -> IO ()
+addFeed (Gossiper (mFeeds)) feed = do
+     atomically $ do
+        feeds <- takeTMVar mFeeds
+        putTMVar mFeeds (Feed.insert feed feeds)
+
+writeFeed :: ToJSON a => RPC.Stream -> Feed.Feed a -> IO (Either Text ())
+writeFeed stream (Feed.Feed _ msgs) = do
+  return <$> forM_
+    msgs
+    (\msg -> do
+      let msg' = Feed.encodeJSONVerifiableMessage msg
+      err <- RPC.writeStream stream def (RPC.JSONPayload msg')
+      either (\err -> print err) (\_ -> return ()) err
+    )
+
+instance ToJSON a => RPC.Handler (Gossiper a) where
+  endpoints h = [RPC.Endpoint ["createHistoryStream"] RPC.Source]
+
+  serve (Gossiper mFeeds) (RPC.Endpoint ["createHistoryStream"] RPC.Source) arg stream
+    = do
+      feeds <- atomically $ readTMVar mFeeds
+      let req = decodeJSON (encodeJSON arg) :: Either Text [Request]
+      case req of
+        Left  err   -> do
+            return . return $ ()
+        Right [] -> return . return $ ()
+        Right [arg] -> do
+          case Feed.lookup (id arg) feeds of
+            Just feed -> writeFeed stream feed
+            Nothing   -> return . return $ ()
+
+  notifyConnect _ _ = return . return $ ()
+
+  notifyDisconnect _ _ = return . return $ ()
diff --git a/src/Ssb/Peer/RPC/Room.hs b/src/Ssb/Peer/RPC/Room.hs
new file mode 100644
index 0000000..47bc956
--- /dev/null
+++ b/src/Ssb/Peer/RPC/Room.hs
@@ -0,0 +1,330 @@
+-- | This module implements Scuttlebutt's Remote Procedure Call for
+-- Rooms.
+--
+-- For more information kindly refer [WHERE]
+
+-- TODO: Documentation for SSB-Room
+
+module Ssb.Peer.RPC.Room where
+
+
+import           Protolude               hiding ( Identity )
+import qualified Data.Aeson                    as Aeson
+import           Control.Concurrent.STM
+import           Data.Default
+import qualified Data.Map.Strict               as Map
+import           Data.Time.Clock                ( UTCTime
+                                                , getCurrentTime
+                                                )
+import qualified Data.Text                     as Text
+
+import  Ssb.Aux
+import qualified Ssb.Identity                  as Ssb
+import qualified Ssb.Pub                       as Ssb
+import           Ssb.Network
+import qualified Ssb.Feed                      as Feed
+import qualified Ssb.Peer.RPC                  as RPC
+
+seed :: Text
+seed = "SSB+Room+PSK3TLYC2T86EHQCUHBUHASCASE18JBV24="
+
+data Invite = Invite
+    { host :: Host
+    , port :: Port
+    , key  :: Ssb.PublicKey
+    } deriving (Eq, Show)
+
+formatInvite :: Invite -> Text
+formatInvite arg =
+  "net:"
+    <> host arg
+    <> ":"
+    <> port arg
+    <> "~shs"
+    <> ":"
+    <> formatPublicKey' arg
+    <> ":"
+    <> seed
+ where
+  formatPublicKey' arg =
+    Text.dropEnd 8 $ Text.drop 1 $ Ssb.formatPublicKey $ key arg
+
+-- TODO: Seriously, figure out how to use duplicate field names
+data Room = Room {
+      endpoints     :: TMVar (Map Ssb.PublicKey (RPC.ConnState, [Tunnel]))
+    , notifyChange  :: TChan Bool
+    , roomName      :: Text
+    , roomDesc      :: Text
+    , tunnels       :: TMVar (Map Tunnel [ThreadId])
+    }
+
+newRoom :: Text -> Text -> IO Room
+newRoom name desc = do
+  endpoints <- newTMVarIO Map.empty
+  notifier  <- newBroadcastTChanIO
+  tunnels   <- newTMVarIO Map.empty
+  return $ Room endpoints notifier name desc tunnels
+
+getEndpoints :: Room -> IO [Ssb.PublicKey]
+getEndpoints h = do
+  let mVar = endpoints h
+  Map.keys <$> atomically (readTMVar mVar)
+
+lookUpPeer :: Room -> Ssb.PublicKey -> IO (Maybe RPC.ConnState)
+lookUpPeer h peer = do
+  endpoints' <- atomically $ readTMVar (endpoints h)
+  return $ fst <$> Map.lookup peer endpoints'
+
+errConnLimitReached = "peer limit reached"
+
+registerPeer :: Room -> RPC.Stream -> IO (Either Text ())
+registerPeer h stream = do
+  let mVar = endpoints h
+  atomically $ do
+    endpoints' <- takeTMVar mVar
+    if Map.size endpoints' == (maxBound :: Int)
+      then return $ Left errConnLimitReached
+      else do
+        putTMVar mVar
+          $ Map.insert (RPC.peer stream) (RPC.conn stream, []) endpoints'
+        writeTChan (notifyChange h) True
+        return $ Right ()
+
+unregisterPeer :: Room -> Ssb.PublicKey -> IO ()
+unregisterPeer h peer = do
+  let mVar = endpoints h
+  atomically $ do
+    endpoints' <- takeTMVar mVar
+    putTMVar mVar $ Map.delete peer endpoints'
+    writeTChan (notifyChange h) True
+
+data IsRoomResponse = IsRoomResponse {
+      name          :: Text
+    , description   :: Text
+    } deriving (Generic, Show)
+
+instance Aeson.FromJSON IsRoomResponse
+
+instance Aeson.ToJSON IsRoomResponse
+
+newIsRoomResponse :: Room -> IsRoomResponse
+newIsRoomResponse l = IsRoomResponse (roomName l) (roomDesc l)
+
+announceRequest :: RPC.Request [Text]
+announceRequest =
+  RPC.Request { name = ["tunnel", "announce"], typ = RPC.Async, args = [] }
+
+announce :: RPC.ConnState -> IO (Either Text ())
+announce conn = RPC.requestAsync conn announceRequest
+
+data ConnectRequest = ConnectRequest {
+      target   :: Ssb.PublicKey
+    , portal   :: Ssb.PublicKey
+    } deriving (Generic, Show)
+
+instance Aeson.FromJSON ConnectRequest
+
+instance Aeson.ToJSON ConnectRequest
+
+leaveRequest :: RPC.Request [Text]
+leaveRequest =
+  RPC.Request { name = ["tunnel", "leave"], typ = RPC.Async, args = [] }
+
+leave :: RPC.ConnState -> IO (Either Text ())
+leave conn = RPC.requestAsync conn leaveRequest
+
+pingRequest :: RPC.Request [Text]
+pingRequest =
+  RPC.Request { name = ["tunnel", "ping"], typ = RPC.Async, args = [] }
+
+ping :: RPC.ConnState -> IO (Either Text UTCTime)
+ping conn = RPC.requestAsync conn pingRequest
+
+-- | fork creates a new thread, incrementing the counter in the given mVar.
+fork mVar action = do
+  fork' <- newEmptyTMVarIO
+  atomically $ do
+    forks <- takeTMVar mVar
+    putTMVar mVar $ fork' : forks
+  forkFinally
+    action
+    (\_ -> do
+      print "exiting fork"
+      atomically $ putTMVar fork' ()
+    )
+
+-- | wait returns when all forks have completed.
+waitForkGroup mVar threads = do
+  cs <- atomically $ takeTMVar mVar
+  case cs of
+    []     -> return ()
+    m : ms -> do
+      atomically $ putTMVar mVar ms
+      atomically $ takeTMVar m
+      forM_ threads killThread
+      waitForkGroup mVar []
+
+forwardMessages :: RPC.Stream -> RPC.Stream -> IO (Either Text ())
+forwardMessages s1 s2 = do
+  mMsg <- RPC.readStream s1
+  case mMsg of
+    Nothing  -> return $ Right ()
+    Just msg -> do
+      res <- RPC.writeStream s2 def msg
+      case res of
+        Left  err -> return $ Left err
+        Right _   -> forwardMessages s1 s2
+
+type Tunnel = (Ssb.PublicKey, Ssb.PublicKey)
+
+newTunnel arg1 arg2 =
+  -- the tunnel's entries need to be ordered to make pairs unique
+  if arg1 < arg2 then (arg1, arg2) else (arg2, arg1)
+
+createTunnel :: Room -> (RPC.Stream, RPC.Stream) -> IO (Either Text ())
+createTunnel room (stream1, stream2) = do
+  let peer1  = RPC.connPeer $ RPC.conn stream1
+  let peer2  = RPC.connPeer $ RPC.conn stream2
+  --print
+  --  $  "creating tunnel for "
+  --  <> Ssb.formatPublicKey peer1
+  --  <> " <-> "
+  --  <> Ssb.formatPublicKey peer2
+  let tunnel = newTunnel peer1 peer2
+
+  exists <- atomically $ do
+    tunnels' <- readTMVar (tunnels room)
+    return $ Map.member tunnel tunnels'
+  if exists
+    then return $ Left "only one tunnel allowed"
+    else do
+      waiter  <- newTMVarIO []
+      thread1 <- fork waiter $ forwardMessages stream1 stream2
+      thread2 <- fork waiter $ forwardMessages stream2 stream1
+      let threads = [thread1, thread2]
+
+      atomically $ do
+        endpoints' <- takeTMVar (endpoints room)
+        let endpoints'' = Map.adjust (addTunnel tunnel) (fst tunnel) endpoints'
+        let endpoints''' =
+              Map.adjust (addTunnel tunnel) (snd tunnel) endpoints''
+        putTMVar (endpoints room) endpoints'''
+
+        tunnels' <- takeTMVar (tunnels room)
+        let tunnels'' = Map.insert tunnel threads tunnels'
+        putTMVar (tunnels room) tunnels''
+
+      waitForkGroup waiter threads
+
+      atomically $ do
+        endpoints' <- takeTMVar (endpoints room)
+        let endpoints'' =
+              Map.adjust (removeTunnel tunnel) (fst tunnel) endpoints'
+        let endpoints''' =
+              Map.adjust (removeTunnel tunnel) (snd tunnel) endpoints''
+        putTMVar (endpoints room) endpoints'''
+
+        tunnels' <- takeTMVar (tunnels room)
+        putTMVar (tunnels room) $ Map.delete tunnel tunnels'
+
+      return . return $ ()
+ where
+  addTunnel arg (conn, tunnels) = (conn, tunnels ++ [arg])
+  removeTunnel arg (conn, tunnels) = (conn, filter (arg /=) tunnels)
+
+connect :: Room -> RPC.Stream -> ConnectRequest -> IO (Either Text ())
+connect room stream req = do
+  let tunnel = newTunnel (RPC.connPeer $ RPC.conn $ stream) (target req)
+  tunnels' <- atomically $ readTMVar (tunnels room)
+  mPeer    <- lookUpPeer room (target req)
+  let peerConn = do
+        bool (return ()) errSelfNotAllowed   (fst tunnel == snd tunnel)
+        bool (return ()) errOnlyUniqueTunnel (Map.member tunnel tunnels')
+        maybeToRight errPeerNotAvailable mPeer
+  case peerConn of
+    Left err -> do
+      print $ "errorr! " <> err
+      return $ Left err
+    Right conn -> RPC.request conn (rpcRequest req)
+      $ \peerStream -> createTunnel room (stream, peerStream)
+ where
+  errOnlyUniqueTunnel = Left $ "only unique tunnels are allowed"
+  errPeerNotAvailable = "peer is not connected" :: Text
+  errSelfNotAllowed   = Left $ "connecting to self not allowed"
+  rpcRequest arg =
+    RPC.Request { name = ["tunnel", "connect"], typ = RPC.Duplex, args = [arg] }
+
+leave' :: Room -> Ssb.PublicKey -> IO (Either Text ())
+leave' room peer = do
+  endpoints' <- atomically $ readTMVar (endpoints room)
+  tunnels'   <- atomically $ readTMVar (tunnels room)
+
+  let etunnels = fromMaybe mempty $ snd <$> Map.lookup peer endpoints'
+  forM_ etunnels $ \tunnel -> do
+    let threads = fromMaybe mempty $ Map.lookup tunnel tunnels'
+    forM_ threads killThread
+  unregisterPeer room peer
+  return . return $ ()
+
+instance RPC.Handler Room where
+  endpoints _ =
+    [ RPC.Endpoint ["tunnel", "announce"] RPC.Async
+    , RPC.Endpoint ["tunnel", "connect"] RPC.Duplex
+    , RPC.Endpoint ["tunnel", "endpoints"] RPC.Async
+    , RPC.Endpoint ["tunnel", "leave"] RPC.Async
+    , RPC.Endpoint ["tunnel", "isRoom"] RPC.Async
+    , RPC.Endpoint ["tunnel", "ping"] RPC.Async
+    ]
+
+    -- The announce and leave endpoints are defined by the server's JS, but
+    -- never called by the client.  The official (NodeJS) project uses
+    -- disconnect notifications from the SSB-server.
+    --
+  serve h (RPC.Endpoint ["tunnel", "announce"] _) args stream =
+    registerPeer h stream
+
+  -- should decode request
+  serve h (RPC.Endpoint ["tunnel", "connect"] RPC.Duplex) args stream = do
+    let args' =
+          decodeJSON (toS $ Aeson.encode args) :: Either
+              Text
+              [ConnectRequest]
+    case args' of
+      Left  err       -> return $ Left err
+      Right [connReq] -> connect h stream connReq
+      otherwise       -> return $ Left "bad target argument"
+
+  serve h (RPC.Endpoint ["tunnel", "endpoints"] _) _ stream = do
+    err <- registerPeer h stream
+    case err of
+      Left  msg -> return $ Left msg
+      Right _   -> do
+        change <- atomically $ dupTChan $ notifyChange h
+        while $ do
+          endpoints' <- getEndpoints h
+          let resp = filter (/= RPC.peer stream) endpoints'
+          res <- RPC.writeStreamJSON stream resp
+          if isLeft res then return False else atomically $ readTChan change
+        return $ Right ()
+   where
+    while f = do
+      continue <- f
+      if continue then (while f) else return False
+
+  serve room (RPC.Endpoint ["tunnel", "leave"] _) _ stream =
+    leave' room (RPC.peer stream)
+
+  serve room (RPC.Endpoint ["tunnel", "isRoom"] _) _ stream =
+    RPC.writeStreamJSON stream (newIsRoomResponse room)
+
+  serve room (RPC.Endpoint ["tunnel", "ping"] _) _ stream = do
+    resp <- getCurrentTime
+    RPC.writeStreamJSON stream resp
+
+  serve room endpoint@otherwise arg stream = (RPC.notFoundHandlerFunc endpoint) arg stream
+
+  notifyConnect _ _ = return . return $ ()
+
+  notifyDisconnect room peer = do
+    _ <- leave' room peer
+    return . return $ ()
diff --git a/src/Ssb/Peer/RPC/WhoAmI.hs b/src/Ssb/Peer/RPC/WhoAmI.hs
new file mode 100644
index 0000000..be979fc
--- /dev/null
+++ b/src/Ssb/Peer/RPC/WhoAmI.hs
@@ -0,0 +1,49 @@
+-- | This module implements Scuttlebutt's Remote Procedure Call for
+-- Ping.
+--
+-- For more information kindly refer [WHERE]
+
+-- TODO: Update above documentation
+
+module Ssb.Peer.RPC.WhoAmI where
+
+import           Protolude        hiding ( Identity )
+import           Data.Aeson       as Aeson (FromJSON,ToJSON)
+
+import qualified Ssb.Identity as Ssb
+import qualified Ssb.Feed     as Feed
+import qualified Ssb.Peer.RPC as RPC
+
+whoAmIRequest :: RPC.Request [Text]
+whoAmIRequest = RPC.Request {
+    name = ["whoami"]
+  , typ  = RPC.Async
+  , args = []
+  }
+
+newtype WhoAmIResponse = WhoAmIResponse
+    { id :: Feed.FeedID
+    } deriving (Eq,Generic,Show)
+
+instance FromJSON WhoAmIResponse
+
+instance ToJSON WhoAmIResponse
+
+whoAmI
+  :: RPC.ConnState
+  -> IO (Either Text WhoAmIResponse)
+whoAmI conn = RPC.requestAsync conn whoAmIRequest
+
+newtype Handler = Handler ()
+
+newHandler :: Handler
+newHandler = Handler ()
+
+instance RPC.Handler Handler where
+  endpoints h = [RPC.Endpoint ["whoami"] RPC.Async]
+
+  serve (Handler ssbID) (RPC.Endpoint ["whoami"] RPC.Async) _ stream =
+      RPC.writeStreamJSON stream (WhoAmIResponse $ Feed.FeedID (RPC.peer stream))
+
+  notifyConnect _ _ = return . return $ ()
+  notifyDisconnect _ _ = return . return $ ()
diff --git a/src/Ssb/Peer/SecretHandshake.hs b/src/Ssb/Peer/SecretHandshake.hs
new file mode 100644
index 0000000..4245542
--- /dev/null
+++ b/src/Ssb/Peer/SecretHandshake.hs
@@ -0,0 +1,695 @@
+-- | This module implements Scuttlebutt's Secret Handshake.
+--
+-- For more information kindly refer the to protocol guide
+-- https://ssbc.github.io/scuttlebutt-protocol-guide
+
+-- | TODO: Take care of possible import loop
+-- | TODO: Optimize handling of PublicKey (extractPublicKey)
+
+module Ssb.Peer.SecretHandshake where
+
+import           Protolude               hiding ( Identity )
+import qualified Data.ByteString               as BS
+import           Data.Default
+import qualified Crypto.Hash.SHA256            as SHA256
+import qualified Crypto.Saltine.Core.ScalarMult
+                                               as ScalarMult
+import qualified Crypto.Saltine.Class          as Nacl
+import qualified Crypto.Saltine.Core.Auth      as Auth
+import qualified Crypto.Saltine.Core.Box       as Box
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Core.Sign      as Sign
+
+import           Ssb.Network
+import           Ssb.Identity
+import qualified Sodium
+
+-- | ChallengeLength is the length of a challenge message in bytes
+challengeLength :: Int
+challengeLength = 64
+
+-- | ClientAuthLength is the length of a clientAuth message in bytes
+clientAuthLength :: Int
+clientAuthLength = 16 + 32 + 64
+
+-- | ServerAcceptLength is the length of a serverAccept message in bytes
+serverAcceptLength :: Int
+serverAcceptLength = 16 + 64
+
+-- | MACLength is the length of a MAC in bytes
+macLength :: Int
+macLength = 16
+
+-- | NetworkIdentifier defines which of the possible networks is being used.
+-- Most traffic is on MainNet, and others may be used for testing purposes.
+type NetworkIdentifier = ByteString
+
+type SharedSecret = ScalarMult.GroupElement
+
+-- | SharedSecrets are the result of Scuttlebutt's handshake
+-- TODO: make shared secrets readable and showable
+data SharedSecrets = SharedSecrets
+    { network               :: NetworkIdentifier
+    , secreta               :: Maybe PublicKey
+    , secretA               :: Maybe PublicKey
+    , secretb               :: Maybe PublicKey
+    , secretB               :: Maybe PublicKey
+    , secretab              :: SharedSecret
+    , secretaB              :: SharedSecret
+    , secretAb              :: SharedSecret
+    , serverHMAC            :: Auth.Authenticator
+    }
+
+-- | ConnStatus defines the progress of the handshake.
+data ConnStatus =
+      StartingHandshake
+    | AwaitingClientHello
+    | AwaitingServerHello
+    | AwaitingClientAuthentication
+    | AwaitingServerAccept
+    | HandshakeComplete
+  deriving Show
+
+-- | Message sent between Scuttlebutt peers.
+-- TODO: Add encoding and processing of remaining messages
+data Message =
+      ClientHello       Auth.Authenticator -- | Client's HMAC
+                        PublicKey          -- | Client's Ephemeral Public Key
+                        NetworkIdentifier
+    | ServerHello       Auth.Authenticator -- | Server's HMAC
+                        PublicKey          -- | Server's Ephemeral Public Key
+                        NetworkIdentifier
+    -- TODO: Can this be renamed?
+    | ClientAuthMessage ByteString         -- | Detached Signature A
+                        PublicKey          -- | Client long term Public Key
+    | ServerAccept      ByteString         -- | Detached Signature B
+
+-- | ConnState holds important details during the connection process.
+--
+-- TODO: define a getter method for fields.  Is it possible to get the field
+-- name for the error message?
+data ConnState = ConnState
+    { connState              :: ConnStatus
+    , networkID              :: NetworkIdentifier
+    , clientPrivateKey       :: Maybe PrivateKey
+    , clientPublicKey        :: Maybe PublicKey
+    , clientEphemeralPrivKey :: Maybe PrivateKey
+    , clientEphemeralPubKey  :: Maybe PublicKey
+    , clientHMAC             :: Maybe Auth.Authenticator
+    , serverPrivateKey       :: Maybe PrivateKey
+    , serverPublicKey        :: Maybe PublicKey
+    , serverEphemeralPrivKey :: Maybe PrivateKey
+    , serverEphemeralPubKey  :: Maybe PublicKey
+    , serverHMAC             :: Maybe Auth.Authenticator
+    , sharedSecretab         :: Maybe SharedSecret
+    , sharedSecretaB         :: Maybe SharedSecret
+    , sharedSecretAb         :: Maybe SharedSecret
+    , detachedSignatureA     :: Maybe ByteString
+    , detachedSignatureB     :: Maybe ByteString
+    }
+
+-- | TODO: confirm use of default
+instance Default ConnState  where
+  def = ConnState { connState              = StartingHandshake
+                  , networkID              = ""
+                  , clientPrivateKey       = def
+                  , clientPublicKey        = def
+                  , clientEphemeralPrivKey = def
+                  , clientEphemeralPubKey  = def
+                  , clientHMAC             = def
+                  , serverPrivateKey       = def
+                  , serverPublicKey        = def
+                  , serverEphemeralPrivKey = def
+                  , serverEphemeralPubKey  = def
+                  , serverHMAC             = def
+                  , sharedSecretab         = def
+                  , sharedSecretaB         = def
+                  , sharedSecretAb         = def
+                  , detachedSignatureA     = def
+                  , detachedSignatureB     = def
+                  }
+
+must :: Text -> Maybe a -> Either Text a
+must field = maybeToEither ("missing " <> field)
+
+-- | Create the state for initiating a Handshake given the Scuttlebutt User's key pair.
+newClientConnState
+    :: NetworkIdentifier
+    -> Identity
+    -> PublicKey
+    -> IO ConnState
+newClientConnState network clientID serverPubKey = do
+  let clientPrivKey = Ssb.Identity.privateKey clientID
+  let clientPubKey  = Ssb.Identity.publicKey clientID
+
+  (ephPrivKey, ephPubKey) <- Box.newKeypair
+  return $ def { connState              = StartingHandshake
+               , networkID              = network
+               , clientPrivateKey       = clientPrivKey
+               , clientPublicKey        = Just clientPubKey
+               , clientEphemeralPrivKey = Just $ PrivateKey (Nacl.encode ephPrivKey)
+               , clientEphemeralPubKey  = Just $ PublicKey (Nacl.encode ephPubKey)
+               , serverPublicKey        = Just serverPubKey
+               }
+-- | Create the state for initiating a Handshake given the Scuttlebutt User's key pair.
+newServerConnState
+    :: NetworkIdentifier
+    -> Identity
+    -> IO ConnState
+newServerConnState network serverID = do
+  let serverPrivKey = Ssb.Identity.privateKey serverID
+  let serverPubKey  = Ssb.Identity.publicKey serverID
+
+  (ephPrivKey, ephPubKey) <- Box.newKeypair
+  return $ def { connState              = AwaitingClientHello
+               , networkID              = network
+               , serverEphemeralPrivKey = Just $ PrivateKey (Nacl.encode ephPrivKey)
+               , serverEphemeralPubKey  = Just $ PublicKey (Nacl.encode ephPubKey)
+               , serverPrivateKey       = serverPrivKey
+               , serverPublicKey        = Just serverPubKey
+               }
+
+-- | Create shared secrets given the Handshake's final connection state.
+newSharedSecrets :: ConnState -> Either Text SharedSecrets
+newSharedSecrets state = do
+  ssab <- must "secret key ab" $ sharedSecretab state
+  ssaB <- must "secret key aB" $ sharedSecretaB state
+  ssAb <- must "secret key Ab" $ sharedSecretAb state
+  serverHMAC' <- must "secret HMAC" $ serverHMAC (state :: ConnState)
+  return $ SharedSecrets { network    = networkID state
+                         , secreta    = clientEphemeralPubKey state
+                         , secretA    = clientPublicKey       state
+                         , secretb    = serverEphemeralPubKey state
+                         , secretB    = serverPublicKey       state
+                         , secretab   = ssab
+                         , secretaB   = ssaB
+                         , secretAb   = ssAb
+                         , serverHMAC = serverHMAC'
+                         }
+
+newClientAuthMessage :: ConnState -> Either Text Message
+newClientAuthMessage state = do
+  let network = networkID state
+  cliLTPrivKey  <- must "client Private Key" $ clientPrivateKey state
+  cliLTPubKey   <- must "client Public Key" $ clientPublicKey state
+  srvLTPubKey   <- must "server Public Key" $ serverPublicKey state
+
+  cliEphPrivKey <- must "client Private Key" $ clientEphemeralPrivKey state
+  srvEphPubKey  <- must "server Ephemeral Public Key"
+    $ serverEphemeralPubKey state
+
+  ssab               <- must "shared secret ab" $ sharedSecretab state
+
+  detachedSignatureA <- newDetachedSignatureA network
+                                              srvLTPubKey
+                                              ssab
+                                              cliLTPrivKey
+
+  return $ ClientAuthMessage detachedSignatureA
+                             cliLTPubKey
+
+newClientHello :: ConnState -> Either Text Message
+newClientHello state = do
+    cliEphPubKey <- maybeToEither noKeyMsg $ clientEphemeralPubKey state
+    key          <- maybeToEither badNetMsg $ Nacl.decode (networkID state)
+    let auth = Auth.auth key (extractPublicKey cliEphPubKey)
+    return $ ClientHello auth cliEphPubKey (networkID state)
+   where
+    badNetMsg = "badly formatted Network Identifier"
+    noKeyMsg  = "clientEphemeralKey required"
+
+decodeClientHello :: ConnState -> ByteString -> Either Text Message
+decodeClientHello state buf = do
+  let network                 = networkID state
+  let (hmacbuf, cliEphPubKey) = BS.splitAt 32 buf
+
+  key  <- maybeToEither badNetMsg $ Nacl.decode network
+  auth <- maybeToEither badHMACMsg $ Nacl.decode hmacbuf
+  let msg = cliEphPubKey
+
+  if Auth.verify key auth msg
+    then Right $ ClientHello auth (PublicKey cliEphPubKey) network
+    else Left badVerificationMsg
+ where
+  badNetMsg          = "badly formatted Network Identifier"
+  badHMACMsg         = "badly formatted server HMAC"
+  badPubKeyMsg       = "badly formatted server Public Key"
+  badVerificationMsg = "verification failed"
+
+-- TODO: check if its possible to change the function depending on the return type.
+
+newServerHello :: ConnState -> Either Text Message
+newServerHello state = do
+    srvEphPubKey <- maybeToEither noKeyMsg $ serverEphemeralPubKey state
+    key          <- maybeToEither badNetMsg $ Nacl.decode (networkID state)
+    let auth = Auth.auth key (extractPublicKey srvEphPubKey)
+    return $ ServerHello auth srvEphPubKey (networkID state)
+   where
+    badNetMsg = "badly formatted Network Identifier"
+    noKeyMsg  = "clientEphemeralKey required"
+
+decodeServerHello :: ConnState -> ByteString -> Either Text Message
+decodeServerHello state buf = do
+  let network                 = networkID state
+  let (hmacbuf, srvEphPubKey) = BS.splitAt 32 buf
+
+  key  <- maybeToEither badNetMsg $ Nacl.decode network
+  auth <- maybeToEither badHMACMsg $ Nacl.decode hmacbuf
+  let msg = srvEphPubKey
+
+  if Auth.verify key auth msg
+    then Right $ ServerHello auth (PublicKey srvEphPubKey) network
+    else Left badVerificationMsg
+ where
+  badNetMsg          = "badly formatted Network Identifier"
+  badHMACMsg         = "badly formatted server HMAC"
+  badPubKeyMsg       = "badly formatted server Public Key"
+  badVerificationMsg = "verification failed"
+
+decodeClientAuthMessage :: ConnState -> ByteString -> Either Text Message
+decodeClientAuthMessage state buf = do
+    let network = networkID state
+    serverPublicKey <- must "serverPublicKey" $ serverPublicKey state
+    sharedSecretab  <- must "sharedSecretab" $ sharedSecretab state
+    sharedSecretaB  <- must "sharedSecretaB" $ sharedSecretaB state
+
+    key <-
+        naclDecode "key"
+        $  SHA256.hash
+        $  network
+        <> Nacl.encode sharedSecretab
+        <> Nacl.encode sharedSecretaB
+    let nonce = Nacl.zero
+    msg3 <- maybeToEither "could not open secret box"
+        $ SecretBox.secretboxOpen key nonce buf
+
+    -- TODO: Make the client auth message length a constant
+    msg3 <- if (BS.length msg3 == 96)
+        then (return msg3)
+        else (Left badMessageLength)
+    let detachedSignatureA = BS.take 64 msg3
+    clientLongTermPubKey   <- naclDecode "client Long Term Public Key"
+        $ BS.drop 64 msg3
+
+    let msg =
+          (network :: ByteString)
+          <> (extractPublicKey serverPublicKey)
+          <> SHA256.hash (Nacl.encode sharedSecretab)
+    if Sign.signVerifyDetached
+        clientLongTermPubKey
+        detachedSignatureA
+        msg
+      then Right state {connState = HandshakeComplete}
+      else Left "client verification failed"
+
+    return $ ClientAuthMessage
+        detachedSignatureA
+        (PublicKey $ Nacl.encode clientLongTermPubKey)
+  where
+    badMessageLength = "unexpected length of Client Authentication Message"
+    naclDecode msg = maybeToEither msg . Nacl.decode
+
+newServerAccept :: ConnState -> Either Text Message
+newServerAccept state = do
+      detachedSignatureB' <- maybeToEither noSigB (detachedSignatureB state)
+      return $ ServerAccept detachedSignatureB'
+   where
+      noSigB  = "detachedSignatureB required"
+
+decodeServerAccept :: ConnState -> ByteString -> Either Text Message
+decodeServerAccept state buf = do
+  let network = networkID state
+  sharedSecretab <- must "sharedSecretab" $ sharedSecretab state
+  sharedSecretaB <- must "sharedSecretaB" $ sharedSecretaB state
+  sharedSecretAb <- must "sharedSecretAb" $ sharedSecretAb state
+
+  key            <-
+    naclDecode "key"
+    $  SHA256.hash
+    $  network
+    <> Nacl.encode sharedSecretab
+    <> Nacl.encode sharedSecretaB
+    <> Nacl.encode sharedSecretAb
+  let nonce = Nacl.zero
+
+  detachedSignatureB <- secretBoxOpen key nonce buf
+  return $ ServerAccept detachedSignatureB
+ where
+  naclDecode msg =
+    maybeToEither ("could not decode " <> msg :: Text) . Nacl.decode
+  secretBoxOpen key nonce msg =
+    maybeToEither "could not open secret box"
+      $ SecretBox.secretboxOpen key nonce msg
+
+-- | generate a signature used in the Client Authentication
+newDetachedSignatureA
+  :: NetworkIdentifier
+  -> Ssb.Identity.PublicKey
+  -> SharedSecret
+  -> PrivateKey
+  -> Either Text ByteString
+newDetachedSignatureA network serverLongTermPubKey sharedSecretab clientLongTermPrivKey
+  = do
+    clientLongTermPrivKey' <- maybeToEither badCliKeyMsg
+      $  Nacl.decode $ extractPrivateKey clientLongTermPrivKey
+    let secretChecksum = SHA256.hash $ Nacl.encode sharedSecretab
+    let msg =
+          (network :: ByteString)
+            <> extractPublicKey serverLongTermPubKey
+            <> (secretChecksum :: ByteString)
+    return $ Sign.signDetached clientLongTermPrivKey' msg
+ where
+  badSrvKeyMsg = "badly encoded long term server public key"
+  badCliKeyMsg = "badly encoded long term client private key"
+
+calcSharedSecretab :: PrivateKey -> PublicKey -> Either Text SharedSecret
+calcSharedSecretab cliEphPrivKey srvEphPubKey = do
+  cliEphPrivKey' <- maybeToEither "badly formatted client ephemeral private key"
+      $ Nacl.decode $ extractPrivateKey cliEphPrivKey
+  srvEphPubKey' <- maybeToEither "badly formatted server ephemeral public key"
+      $ Nacl.decode $ extractPublicKey srvEphPubKey
+  return $ ScalarMult.mult cliEphPrivKey' srvEphPubKey'
+
+-- | generate a signature used in the Server acknowledgement
+newDetachedSignatureB
+  :: NetworkIdentifier
+  -> ByteString
+  -> PublicKey
+  -> SharedSecret
+  -> PrivateKey
+  -> Either Text ByteString
+newDetachedSignatureB network detachedSignatureA clientPublicKey sharedSecretab serverPrivateKey = do
+    key <- naclDecode badPrivkey $ extractPrivateKey serverPrivateKey
+    let msg =
+          (network :: ByteString)
+          <> detachedSignatureA
+          <> (extractPublicKey clientPublicKey)
+          <> SHA256.hash (Nacl.encode sharedSecretab)
+    return $ Sign.signDetached key msg
+  where
+    badPrivkey     = "badly formatted private key"
+    naclDecode msg = maybeToEither msg . Nacl.decode
+
+
+-- | Server Longterm PK should be converted to curve25519
+-- Does not look like a problem given the Golang code
+--  TODO: Implement type conversion here
+clientCalcSharedSecretaB :: PrivateKey -> PublicKey -> Either Text SharedSecret
+clientCalcSharedSecretaB clientEphemeralSK serverLongtermPK = do
+  cliEphPrivKey' <- maybeToEither "badly formatted client ephemeral private key"
+      $ Nacl.decode $ extractPrivateKey clientEphemeralSK
+  srvLTPubKey' <- maybeToEither "badly formatted server long term public key"
+      $ Nacl.decode $ extractPublicKey serverLongtermPK
+  curvePublicKey <-
+      maybeToEither "badly formatted curve25519"
+      $ Nacl.decode . Nacl.encode $ Sodium.publicKeyToCurve25519 srvLTPubKey'
+  return $ ScalarMult.mult cliEphPrivKey' curvePublicKey
+
+serverCalcSharedSecretaB :: PrivateKey -> PublicKey -> Either Text SharedSecret
+serverCalcSharedSecretaB serverLongtermSK clientEphemeralPK = do
+  srvLTPrivKey' <- maybeToEither "badly formatted server long term private key"
+      $ Nacl.decode $ extractPrivateKey serverLongtermSK
+  cliEphPubKey' <- maybeToEither "badly formatted client ephemeral public key"
+      $ Nacl.decode $ extractPublicKey clientEphemeralPK
+  curvePrivKey <-
+      maybeToEither "badly formatted curve25519"
+      $ Nacl.decode . Nacl.encode $ Sodium.secretKeyToCurve25519 srvLTPrivKey'
+  return $ ScalarMult.mult curvePrivKey cliEphPubKey'
+
+calcSharedSecretAb :: PrivateKey -> PublicKey -> Either Text SharedSecret
+calcSharedSecretAb clientLongTermPrivKey serverEphemeralPubKey = do
+  cliLTPrivKey' <- naclDecode "badly formatted client long term private key"
+                              $ extractPrivateKey clientLongTermPrivKey
+  curveSecretKey <-
+    naclDecode "badly formatted curve25519"
+    . Nacl.encode
+    $ Sodium.secretKeyToCurve25519 cliLTPrivKey'
+  srvEphPubKey' <- naclDecode "badly formatted server ephemeral public key"
+                              $ extractPublicKey serverEphemeralPubKey
+  return $ ScalarMult.mult curveSecretKey srvEphPubKey'
+  where naclDecode msg = maybeToEither msg . Nacl.decode
+
+serverCalcSharedSecretAb
+    :: PrivateKey
+    -> PublicKey
+    -> Either Text SharedSecret
+serverCalcSharedSecretAb serverEphemeralPrivKey clientLongTermPubKey = do
+    srvEphPrivKey' <- naclDecode "here bad formatted server long term private key"
+                                $ extractPrivateKey serverEphemeralPrivKey
+    cliLTPubKey' <- naclDecode "badly formatted client long term public key"
+                              $ extractPublicKey clientLongTermPubKey
+    curvePublicKey <-
+      naclDecode "badly formatted curve25519"
+        . Nacl.encode
+        $ Sodium.publicKeyToCurve25519 cliLTPubKey'
+    return $ ScalarMult.mult srvEphPrivKey' curvePublicKey
+  where
+    naclDecode msg = maybeToEither msg . Nacl.decode
+
+
+-- | encode and serialize the message in preparation to send to peer.
+encode :: ConnState -> Message -> Either Text ByteString
+encode state msg = case msg of
+  ClientHello auth pubKey network -> do
+    cliEphPubKey <- maybeToEither noKeyMsg $ clientEphemeralPubKey state
+    return $ Nacl.encode auth <> extractPublicKey cliEphPubKey
+   where
+    noKeyMsg  = "clientEphemeralKey required"
+  ServerHello auth pubKey network -> do
+    return $ Nacl.encode auth <> extractPublicKey pubKey
+   where
+    noKeyMsg  = "clientEphemeralKey required"
+  ClientAuthMessage dSigA cliLTPubKey -> do
+    let network        = networkID state
+    ssab               <- must "shared secret ab" $ sharedSecretab state
+    ssaB               <- must "shared secret aB" $ sharedSecretaB state
+
+    key <-
+      maybeToEither badKeyMsg
+      $  Nacl.decode
+      $  SHA256.hash
+      $  network
+      <> Nacl.encode ssab
+      <> Nacl.encode ssaB
+    let nonce = Nacl.zero
+    let msg   = dSigA <> extractPublicKey cliLTPubKey
+    return $ SecretBox.secretbox key nonce msg
+    where badKeyMsg = "clientEphemeralKey required"
+  ServerAccept detachedSignatureB -> do
+      let network        = networkID state
+      ssab               <- must "shared secret ab" $ sharedSecretab state
+      ssaB               <- must "shared secret aB" $ sharedSecretaB state
+      ssAb               <- must "shared secret Ab" $ sharedSecretAb state
+
+      key <-
+          maybeToEither badKeyMsg
+          $ Nacl.decode
+          $ SHA256.hash
+          $ ((network :: ByteString)
+          <> Nacl.encode ssab
+          <> Nacl.encode ssaB
+          <> Nacl.encode ssAb)
+      let nonce = Nacl.zero
+      let msg   = detachedSignatureB
+      return $ SecretBox.secretbox key nonce msg
+    where badKeyMsg = "clientEphemeralKey required"
+
+-- | update the connection state and return any reponse message for the peer.
+-- TODO: Process secretAb
+process :: ConnState -> Message -> IO (Either Text (ConnState, Maybe Message))
+process state (ClientHello hmac cliEphPubKey network) = do
+  stateUpdate <- return $ do
+    srvLTPrivKey  <- must "server Private Key"
+        $ serverPrivateKey state
+    srvEphPrivKey <- must "server ephemeral Private Key"
+        $ serverEphemeralPrivKey state
+
+    ssab        <- calcSharedSecretab srvEphPrivKey cliEphPubKey
+    -- TODO: srvLTPubKey should be curved Process sk_to_curve25519
+    ssaB        <- serverCalcSharedSecretaB srvLTPrivKey cliEphPubKey
+
+    return $ state { connState             = AwaitingClientAuthentication
+                   , clientEphemeralPubKey = Just cliEphPubKey
+                   , serverHMAC            = Just hmac
+                   , sharedSecretab        = Just ssab
+                   , sharedSecretaB        = Just ssaB
+                   }
+  return $ stateUpdate >>= \state' -> case newServerHello state' of
+    Right msg' -> return $ (state', Just msg')
+    Left  err  -> Left err
+
+process state (ServerHello hmac ephPubKey network) = do
+  stateUpdate <- return $ do
+    cliLTPrivKey  <- must "client Private Key" $ clientPrivateKey state
+    cliEphPrivKey <- must "ephemeral client Private Key"
+      $ clientEphemeralPrivKey state
+    srvLTPubKey <- must "server Public Key" $ serverPublicKey state
+
+    ssab        <- calcSharedSecretab cliEphPrivKey ephPubKey
+    ssaB        <- clientCalcSharedSecretaB cliEphPrivKey srvLTPubKey
+    ssAb        <- calcSharedSecretAb cliLTPrivKey ephPubKey
+
+    return $ state { connState             = AwaitingServerAccept
+                   , serverHMAC            = Just hmac
+                   , serverEphemeralPubKey = Just ephPubKey
+                   , sharedSecretab        = Just ssab
+                   , sharedSecretaB        = Just ssaB
+                   , sharedSecretAb        = Just ssAb
+                   }
+  return $ stateUpdate >>= \state' -> case newClientAuthMessage state' of
+    Right msg' -> return $ (state', Just msg')
+    Left  err  -> Left err
+
+process state (ClientAuthMessage detachedSignatureA clientLongTermPubKey) = do
+    stateUpdate <- return $ do
+        let network = networkID state
+        srvPrivKey <- must "server private key"
+            $ serverPrivateKey state
+        srvEphPrivKey <- must "server Long Term ephemeral private key"
+            $ serverEphemeralPrivKey state
+        sharedSecretAb <- serverCalcSharedSecretAb srvEphPrivKey clientLongTermPubKey
+        sharedSecretab <- must "shared secret ab" $ sharedSecretab state
+
+        detachedSignatureB <- newDetachedSignatureB
+            network
+            detachedSignatureA
+            clientLongTermPubKey
+            sharedSecretab
+            srvPrivKey
+
+        return $ state { connState          = HandshakeComplete
+                       , detachedSignatureA = Just detachedSignatureA
+                       , detachedSignatureB = Just detachedSignatureB
+                       , clientPublicKey    = Just clientLongTermPubKey
+                       , sharedSecretAb     = Just sharedSecretAb
+                       }
+    return $ stateUpdate >>= \state' -> case newServerAccept state' of
+      Right msg' -> return $ (state', Just msg')
+      Left  err  -> Left err
+
+process state (ServerAccept dSigB) = do
+  stateUpdate <- return $ do
+    let network = networkID state
+    cliLTPrivKey <- must "client private key" $ clientPrivateKey state
+    cliLTPubKey <- must "client public key" $ clientPublicKey state
+    srvLTPubKey <- must "server public key" $ serverPublicKey state
+    ssab <- must "shared secret ab" $ sharedSecretab state
+
+    detachedSignatureA <- newDetachedSignatureA network
+                                                srvLTPubKey
+                                                ssab
+                                                cliLTPrivKey
+
+    keyBuf <- must "server Public Key" $ serverPublicKey state
+    key <- maybeToEither "badly formatted public key" $ Nacl.decode $ extractPublicKey keyBuf
+    let msg = network <> detachedSignatureA <> extractPublicKey cliLTPubKey <> SHA256.hash (Nacl.encode ssab)
+
+    if Sign.signVerifyDetached key dSigB msg
+      then Right state {connState = HandshakeComplete}
+      else Left "server verification failed"
+
+  return $ case stateUpdate of
+    Right state' -> return (state', Nothing)
+    Left  err  -> Left err
+
+-- TODO: Investigate a better way to separate network from handshake logic
+type ReadFn = Int -> IO (Maybe ByteString)
+type SendFn = ByteString -> IO ()
+
+-- | readMsg decodes the next expected message from the byte stream.
+readMsg :: ConnState -> ReadFn -> IO (Either Text Message)
+readMsg state read = case connState state of
+  AwaitingClientHello -> do
+    mbuf <- read' challengeLength
+    return $ do
+      buf <- mbuf
+      decodeClientHello state buf
+  AwaitingServerHello -> do
+    mbuf <- read' challengeLength
+    return $ do
+      buf <- mbuf
+      decodeServerHello state buf
+  AwaitingClientAuthentication -> do
+    mbuf <- read' 112
+    return $ do
+      buf <- mbuf
+      decodeClientAuthMessage state buf
+  AwaitingServerAccept -> do
+    mbuf <- read' serverAcceptLength
+    return $ do
+      buf <- mbuf
+      decodeServerAccept state buf
+  _ -> return $ Left "unknown state"
+  where read' len = maybeToEither "connection broken" <$> read len
+
+-- TODO: use Either instead
+sendMsg :: SendFn -> ConnState -> Message -> IO ()
+sendMsg send state msg = do
+  case encode state msg of
+    Left  err -> die err
+    Right buf -> send buf
+
+-- | startHandshake initializes the connection with the Scuttlebutt peer
+-- returning the new shared secrets upon completion.
+startHandshake
+  :: SendFn
+  -> ReadFn
+  -> NetworkIdentifier
+  -> Identity
+  -> PublicKey
+  -> IO (Either Text SharedSecrets)
+startHandshake send recv network clientID srvPubKey = do
+  state <- newClientConnState network clientID srvPubKey
+  let clientHello = fromRight undefined (newClientHello state)
+  let state'      = state { connState = AwaitingServerHello }
+  finalState <- loop state' recv (Just clientHello)
+  return $ finalState >>= newSharedSecrets
+ where
+  loop :: ConnState -> ReadFn -> Maybe Message -> IO (Either Text ConnState)
+  loop state _    Nothing    = return . return $ state
+  loop state recv (Just msg) = do
+    sendMsg send state msg
+    case connState state of
+      HandshakeComplete -> return . return $ state
+      _                 -> do
+        resp <- readMsg state recv
+        case resp of
+          Left  err -> return $ Left err
+          Right msg -> do
+            res <- process state msg
+            case res of
+                Left err -> return $ Left ("handshake error while connecting to peer: " <> err)
+                Right (state', msg') ->
+                  loop state' recv msg'
+
+welcomeHandshake
+  :: SendFn
+  -> ReadFn
+  -> NetworkIdentifier
+  -> Identity
+  -> IO (Either Text SharedSecrets)
+welcomeHandshake send recv network serverID = do
+    state <- newServerConnState network serverID
+    finalState <- loop state
+    return $ finalState >>= newSharedSecrets
+  where
+    loop :: ConnState -> IO (Either Text ConnState)
+    loop state = do
+      msg <- readMsg state recv
+      case msg of
+          Left  err -> return $ Left err
+          Right msg -> do
+            res <-  process state msg
+            case res of
+                Left err -> return $ Left $ "handshake failed: " <> err
+                Right (state', msg') ->
+                    case msg' of
+                        Nothing -> return $ Right state'
+                        Just msg'' -> do
+
+                          sendMsg send state' msg''
+                          case connState state' of
+                            HandshakeComplete -> return $ Right state'
+                            _                 -> loop state'
+
+
diff --git a/src/Ssb/Peer/TCP.hs b/src/Ssb/Peer/TCP.hs
new file mode 100644
index 0000000..27e3f07
--- /dev/null
+++ b/src/Ssb/Peer/TCP.hs
@@ -0,0 +1,100 @@
+-- | This module implements basic TCP connectivity for Scuttlebutt.
+
+module Ssb.Peer.TCP where
+
+import           Protolude               hiding ( Identity )
+import           Data.Maybe                     ( fromJust )
+import qualified Network.Simple.TCP            as TCP
+
+import           Ssb.Aux
+import qualified Ssb.Identity                  as Ssb
+import           Ssb.Network
+import           Ssb.Peer
+import qualified Ssb.Peer.BoxStream            as BoxStream
+import qualified Ssb.Peer.SecretHandshake      as SH
+import qualified Ssb.Peer.RPC                  as RPC
+
+connectBoxStream
+  :: Host
+  -> Port
+  -> NetworkIdentifier
+  -> Ssb.Identity
+  -> Ssb.Identity
+  -> (BoxStream.Conn -> IO ())
+  -> IO (Either Text ())
+connectBoxStream host port networkID id peer cmd =
+  TCP.connect (toS host) (toS port) $ \(socket, addr) -> do
+    res <- SH.startHandshake (TCP.send socket)
+                                       (TCP.recv socket)
+                                       networkID
+                                       id
+                                       (Ssb.publicKey peer)
+    case res of
+        Left err -> return $ Left ("client handshake error: " <> err)
+        Right sharedSecrets -> do
+          conn <- BoxStream.connectServer socket sharedSecrets
+          case conn of
+            Left  err  -> return (Left err)
+            Right conn -> return <$> cmd conn
+
+serveBoxStream
+  :: Host
+  -> Port
+  -> NetworkIdentifier
+  -> Ssb.Identity
+  -> (BoxStream.Conn -> Ssb.Identity -> IO ())
+  -> IO ()
+serveBoxStream host port networkID id cmd =
+  TCP.serve (TCP.Host $ toS host) (toS port) $ \(socket, remoteAddr) -> do
+    res <- SH.welcomeHandshake (TCP.send socket)
+                                         (TCP.recv socket)
+                                         networkID
+                                         id
+    case res of
+        Left err -> print $ "client handshake error: " <> err
+        Right sharedSecrets -> do
+            let peerID = (fromMaybe undefined $ SH.secretA sharedSecrets)
+            conn <- BoxStream.connectServer socket sharedSecrets
+            case conn of
+              Left  err  -> print $ "client error: " <> err
+              Right conn -> cmd conn (Ssb.Identity Nothing peerID)
+
+connectRPC
+  :: RPC.Handler a
+  => a
+  -> Host
+  -> Port
+  -> NetworkIdentifier
+  -> Ssb.Identity
+  -> Ssb.Identity
+  -> (RPC.ConnState -> IO ())
+  -> IO (Either Text ())
+connectRPC handler host port networkID id peer cmd =
+  TCP.connect (toS host) (toS port) $ \(socket, addr) -> do
+    res <- SH.startHandshake (TCP.send socket)
+                                       (TCP.recv socket)
+                                       networkID
+                                       id
+                                       (Ssb.publicKey peer)
+    case res of
+        Left err -> return $ error ("client handshake error: " <> err)
+        Right sharedSecrets -> do
+            conn <- BoxStream.connectClient socket sharedSecrets
+            case conn of
+              Left  err  -> return $ Left err
+              Right conn -> RPC.connect conn handler (Ssb.publicKey peer) cmd
+
+serveRPC
+  :: RPC.Handler a
+  => a
+  -> Host
+  -> Port
+  -> NetworkIdentifier
+  -> Ssb.Identity
+  -> IO ()
+serveRPC handler host port networkID id =
+  serveBoxStream host port networkID id $ \conn peer -> do
+    res <- RPC.connect conn handler (Ssb.publicKey peer) (\_ -> return ())
+    case res of
+      Left  err -> print $ "RPC error serving client: " <> err
+      Right _   -> return ()
diff --git a/src/Ssb/Pub.hs b/src/Ssb/Pub.hs
new file mode 100644
index 0000000..9ed5410
--- /dev/null
+++ b/src/Ssb/Pub.hs
@@ -0,0 +1,47 @@
+-- | This module defines SSB pubs used as a gathering point for peers not sharing a local
+-- network.
+--
+-- https://ssbc.github.io/scuttlebutt-protocol-guide/#pubs
+module Ssb.Pub where
+
+import           Protolude
+import           Control.Arrow ((***))
+import qualified Data.Text as Text
+import qualified Data.ByteString.Base64        as Base64
+
+import           Ssb.Identity
+import           Ssb.Network
+
+data Invite = Invite
+    {
+    } deriving (Eq)
+
+data PubAddress = PubAddress
+    { host :: Host
+    , port :: Port
+    , key  :: PublicKey
+    } deriving (Eq, Show)
+
+-- | Create a Pub Address from the given text.
+-- Example string "net:some.ho.st:8008~shs:SomeActuallyValidPubKey="
+parsePub :: Text -> Either Text PubAddress
+parsePub txt = do
+    let (protocol, postProtocol) = split ":" txt
+    let (addressPort, postAddress) = split "~" postProtocol
+    let (address, port) = splitOnEnd ":" addressPort
+    let (hashType, key) = split ":" postAddress
+    return PubAddress
+      { host = address
+      , port = port
+      , key  = PublicKey $ Base64.decodeLenient $ toS key
+      }
+  where
+    split c arg = (identity *** Text.drop 1) $ Text.breakOn c arg
+    splitOnEnd c arg = (Text.dropEnd 1 *** identity) $ Text.breakOnEnd c arg
+
+-- TODO: Complete formatPub
+formatPub :: PubAddress -> Text
+formatPub pub = undefined
+
+newtype PubMessage = PubMessage PubAddress
+    deriving (Eq, Show)
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..7e7ab39
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,64 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-14.27
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.9"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000..e24dcac
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 524996
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml
+    sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0
+  original: lts-14.27
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..cd4753f
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"