~haskell-guy/ssb-haskell

ref: 41cde99ec6189dbecca6803a5aa4f6f18142e8ba ssb-haskell/src/Ssb/Feed.hs -rw-r--r-- 11.1 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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
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"