~haskell-guy/ssb-haskell

ref: 41cde99ec6189dbecca6803a5aa4f6f18142e8ba ssb-haskell/app/Main.hs -rw-r--r-- 5.0 KiB
41cde99e — Haskell Guy initial commit 10 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
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