~haskell-guy/ssb-haskell

41cde99ec6189dbecca6803a5aa4f6f18142e8ba — Haskell Guy 11 months ago
initial commit
A  => .gitignore +3 -0
@@ 1,3 @@
.stack-work/
ssb-haskell.cabal
*~
\ No newline at end of file

A  => ChangeLog.md +3 -0
@@ 1,3 @@
# Changelog for ssb-haskell

## Unreleased changes

A  => LICENSE +19 -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.

A  => README.md +67 -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='
```

A  => Setup.hs +2 -0
@@ 1,2 @@
import Distribution.Simple
main = defaultMain

A  => app/Main.hs +155 -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

A  => package.yaml +74 -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

A  => src/Sodium.hs +99 -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)


A  => src/Ssb.hs +10 -0
@@ 1,10 @@
module Ssb
  ( ssbInit
  )
where

import           Protolude
import qualified Crypto.Saltine                as Nacl

ssbInit :: IO ()
ssbInit = Nacl.sodiumInit

A  => src/Ssb/Aux.hs +67 -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

A  => src/Ssb/Discovery.hs +22 -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)

A  => src/Ssb/Feed.hs +342 -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"

A  => src/Ssb/Identity.hs +82 -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
                  }

A  => src/Ssb/Network.hs +8 -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

A  => src/Ssb/Peer.hs +60 -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)

A  => src/Ssb/Peer/BoxStream.hs +367 -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

A  => src/Ssb/Peer/RPC.hs +859 -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)

A  => src/Ssb/Peer/RPC/Gossip.hs +139 -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 $ ()

A  => src/Ssb/Peer/RPC/Room.hs +330 -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 $ ()

A  => src/Ssb/Peer/RPC/WhoAmI.hs +49 -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 $ ()

A  => src/Ssb/Peer/SecretHandshake.hs +695 -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'



A  => src/Ssb/Peer/TCP.hs +100 -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 ()

A  => src/Ssb/Pub.hs +47 -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)

A  => stack.yaml +64 -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

A  => stack.yaml.lock +12 -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

A  => test/Spec.hs +2 -0
@@ 1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"