initial commit

1 files changed, 342 insertions, 0 deletions

diff --git a/src/Ssb/Feed.hs b/src/Ssb/Feed.hs
new file mode 100644
index 0000000..f4e96c2
--- /dev/null
+++ b/src/Ssb/Feed.hs
@@ -0,0 +1,342 @@
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+
+module Ssb.Feed where
+
+import           Protolude               hiding ( Identity
+                                                , sequence
+                                                , hash
+                                                )
+
+import           Control.Monad.Fail
+import           Control.Concurrent.STM
+import           Data.Aeson                     ( FromJSON
+                                                , ToJSON
+                                                )
+import qualified Data.Map.Strict               as Map
+
+import qualified Crypto.Hash.SHA256            as SHA256
+import qualified Crypto.Saltine.Class          as Nacl
+import qualified Crypto.Saltine.Core.Sign      as NaclSign
+
+import qualified Data.Aeson                    as Aeson
+import           Data.Aeson                    as Aeson (object, (.=))
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Base64        as Base64
+import           Data.Either.Combinators        ( mapLeft
+                                                , mapRight
+                                                )
+import qualified Data.HashMap.Strict           as HashMap
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import           Data.Time.Clock.POSIX          ( getPOSIXTime )
+import           Numeric.Natural
+import           System.IO.Unsafe
+
+import           Ssb.Aux
+import           Ssb.Identity
+
+import           Turtle
+
+type Time = Int
+
+newtype FeedID = FeedID PublicKey
+  deriving (Eq,Generic,Ord,Show)
+
+formatFeedID :: FeedID -> Text
+formatFeedID = formatPublicKey . extractFeedID
+
+extractFeedID :: FeedID -> PublicKey
+extractFeedID (FeedID pubKey) = pubKey
+
+parseFeedID :: Text -> Either Text FeedID
+parseFeedID arg = FeedID <$> parsePublicKey arg
+
+instance FromJSON FeedID where
+  parseJSON = Aeson.withText "FeedID" $ \v -> case parseFeedID v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON FeedID where
+  toJSON arg = Aeson.String $ formatFeedID arg
+
+newtype MessageID = MessageID ByteString
+  deriving (Eq,Show)
+
+newMessageID :: ByteString -> MessageID
+newMessageID buf = MessageID (SHA256.hash buf)
+
+extractMessageID :: MessageID -> ByteString
+extractMessageID (MessageID buf) = buf
+
+-- | return the Humand Readable form.
+-- Format of '%[base64 messageId].sha256', the '.sha256' is appended for
+-- forward compatibility, and is currently assumed.
+formatMessageID :: MessageID -> Text
+formatMessageID (MessageID buf) = "%" <> toS (Base64.encode buf) <> ".sha256"
+
+-- | TODO: make safe
+parseMessageID :: Text -> Either Text MessageID
+parseMessageID arg = decode $ T.dropEnd constLen $ T.drop 1 arg
+ where
+  constLen = T.length ".sha256"
+  decode :: Text -> Either Text MessageID
+  decode = mapRight MessageID . mapLeft toS . Base64.decode . toS
+
+instance FromJSON MessageID where
+  parseJSON = Aeson.withText "MessageID" $ \v -> case parseMessageID v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON MessageID where
+  toJSON arg = Aeson.String $ formatMessageID arg
+
+data HashType = SHA256
+  deriving (Eq,Generic,Show)
+
+formatHashType :: HashType -> Text
+formatHashType SHA256 = "sha256"
+
+parseHashType :: Text -> Either Text HashType
+parseHashType "sha256" = Right SHA256
+parseHashType _        = Left "unknown hash"
+
+instance FromJSON HashType where
+  parseJSON = Aeson.withText "HashType" $ \v -> case parseHashType v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON HashType where
+  toJSON arg = Aeson.String $ formatHashType arg
+
+data Signature = Signature ByteString
+  deriving (Generic,Eq,Show)
+
+extractSignature :: Signature -> ByteString
+extractSignature (Signature buf) = buf
+
+formatSignature :: Signature -> Text
+formatSignature (Signature buf) = toS (Base64.encode buf) <> ".sig.ed25519"
+
+parseSignature :: Text -> Either Text Signature
+parseSignature txt = decode $ T.dropEnd constLen txt
+ where
+  constLen = T.length ".sig.ed25519"
+  decode :: Text -> Either Text Signature
+  decode = mapRight Signature . mapLeft toS . Base64.decode . toS
+
+instance FromJSON Signature where
+  parseJSON = Aeson.withText "Signature" $ \v -> case parseSignature v of
+    Left  err -> fail $ toS err
+    Right a   -> return a
+
+instance ToJSON Signature where
+  toJSON arg = Aeson.String $ formatSignature arg
+
+data Message a = Message
+  { previous :: Maybe MessageID
+  , author :: FeedID
+  , sequence :: Natural
+  , timestamp :: Time
+  , hash :: HashType
+  , content :: a
+  , signature :: Maybe Signature
+  } deriving (Generic,Eq,Show)
+
+instance FromJSON a => FromJSON (Message a)
+
+instance (ToJSON a) => ToJSON (Message a)
+
+newtype MessageNoSig a = MessageNoSig (Message a)
+  deriving (Generic, Eq, Show)
+
+instance (ToJSON a) => ToJSON (MessageNoSig a) where
+  toJSON (MessageNoSig msg) = object [
+      "previous" .= previous msg
+    , "author" .= author msg
+    , "timestamp" .= timestamp msg
+    , "sequence" .= sequence msg
+    , "content" .= content msg
+    , "hash" .= hash msg
+    ]
+
+data Feed a = Feed Identity [VerifiableMessage a]
+  deriving (Eq,Show)
+
+empty id = Feed id []
+
+instance Foldable Feed where
+  foldMap f (Feed id msgs) = foldMap f (content . vmMessage <$> msgs)
+
+data Feeds a = Feeds (Map FeedID (Feed a))
+
+emptyFeeds :: ToJSON a => Feeds a
+emptyFeeds = (Feeds Map.empty)
+
+lookup :: ToJSON a => FeedID -> Feeds a -> Maybe (Feed a)
+lookup id (Feeds m) = Map.lookup id m
+
+insert :: ToJSON a => Feed a -> Feeds a -> Feeds a
+insert feed (Feeds m) = Feeds (Map.insert (id feed) feed m)
+ where
+  id (Feed id _) = FeedID (publicKey id)
+
+-- | Message Verification
+--  Legacy verification of a Message requires keeping track of the JSON value
+--  ordering.  Haskell's underlying JSON serialization mechanisms cannot be
+--  relied on to preserve this.
+--
+-- There are two values which use this funny encoding, the message reference
+-- -and- the signature.
+
+-- | VerifiableMessage keeps track of the original JSON payload for signature
+-- verification.
+data VerifiableMessage a = VerifiableMessage
+  { vmMessage :: Message a
+  , vmMessageID :: MessageID
+  , vmSignature :: Signature
+  , vmSignedPayload :: ByteString
+  } deriving (Generic,Eq,Show)
+
+-- TODO: verify message on creation in newVerifiableMessage
+
+withSignature :: Signature -> ByteString -> ByteString
+withSignature signature buf = (dropEnd (BS.length endTxt) buf) <> sigTxt
+ where
+  dropEnd num = BS.reverse . (BS.drop num) . BS.reverse
+  sigTxt =
+    ",\n  \"signature\": "
+      <> "\""
+      <> toS (formatSignature signature)
+      <> "\""
+      <> endTxt
+  endTxt = "\n}"
+
+-- | TODO: implement stricter version of withoutSignature
+withoutSignature :: ByteString -> ByteString
+withoutSignature buf =
+  appendToEnd "\n}"
+    $ BS.reverse
+    $ BS.drop (BS.length signaturePattern)
+    $ snd
+    $ BS.breakSubstring (BS.reverse signaturePattern) (BS.reverse buf)
+ where
+  appendToEnd      = \x y -> BS.append y x
+  signaturePattern = ",\n  \"signature\":"
+
+newVerifiableMessage
+  :: ByteString -> Message a -> IO (Either Text (VerifiableMessage a))
+newVerifiableMessage origJSONPayload msg = do
+  signedPayload <- encodeForSigning False origJSONPayload
+  return $ do
+    signature'     <- withErr "expected message signature" $ signature msg
+    signedPayload' <- signedPayload
+    return $ VerifiableMessage { vmMessage       = msg
+                               , vmMessageID     = newMessageID signedPayload'
+                               , vmSignature     = signature'
+                               , vmSignedPayload = signedPayload'
+                               }
+
+decodeJSONVerifiableMessage
+  :: FromJSON a => ByteString -> IO (Either Text (VerifiableMessage a))
+decodeJSONVerifiableMessage buf =
+  either (return . Left) (newVerifiableMessage buf) (decodeJSON buf)
+
+encodeJSONVerifiableMessage :: VerifiableMessage a -> ByteString
+encodeJSONVerifiableMessage = vmSignedPayload
+
+atMayFeed :: Int -> Feed a -> Maybe (VerifiableMessage a)
+atMayFeed i (Feed _ msgs) = atMay msgs i
+
+-- | append verifies and appends the Message to the Feed, returning an error if
+-- verification fails.
+append :: ToJSON a => Feed a -> VerifiableMessage a -> Either Text (Feed a)
+append (Feed id msgs) msg = do
+  if (verify id msg)
+    then (return (Feed id (msgs ++ [msg])))
+    else (error "verification failed")
+
+appendContent :: ToJSON a => Feed a -> a -> IO (Either Text (Feed a))
+appendContent (Feed id msgs) content = do
+  timestamp <- (1000 *) <$> getPOSIXTime
+  let msg = Message { previous  = vmMessageID <$> atMay msgs (length msgs - 1)
+                    , author    = FeedID (publicKey id)
+                    , sequence  = fromIntegral (length msgs) + 1
+                    , timestamp = round timestamp
+                    , hash      = SHA256
+                    , content   = content
+                    , signature = Nothing
+                    }
+  vMsg <- signMessage id msg
+  return $ (\x -> Feed id (msgs ++ [x])) <$> vMsg
+
+signMessage
+  :: ToJSON a => Identity -> Message a -> IO (Either Text (VerifiableMessage a))
+signMessage id msg = do
+  buf' <- encodeForSigning True $ encodeJSON (MessageNoSig msg)
+
+  let args = do
+        key  <- withErr "private key required for signing" $ privateKey id
+        key' <-
+          withErr "could not decode private key"
+          $ Nacl.decode
+          . extractPrivateKey
+          $ key
+        buf'' <- buf'
+        return (key', buf'')
+  case args of
+    Right (key, buf) -> do
+      let signature = Signature (NaclSign.signDetached key buf)
+      vMsg <- newVerifiableMessage (withSignature signature buf)
+                           msg { signature = Just signature }
+      return $ do
+          vMsg' <- vMsg
+          if (verify id vMsg')
+            then (return vMsg')
+            else (error "signing failed verification")
+    Left err -> return $ error err
+
+verify :: ToJSON a => Identity -> VerifiableMessage a -> Bool
+verify id msg = do
+  let args = do
+        key <- withErr "could not decode public key"
+          $ Nacl.decode (extractPublicKey (publicKey id))
+        let sig = extractSignature $ vmSignature msg
+        let buf = withoutSignature $ vmSignedPayload msg
+        return (key, sig, buf)
+  case args of
+    Right (key, sig, buf) -> NaclSign.signVerifyDetached key sig buf
+    Left  err             -> False
+
+{-# NOINLINE v8Input #-}
+v8Input :: TMVar ByteString
+v8Input = unsafePerformIO newEmptyTMVarIO
+
+{-# NOINLINE v8Output #-}
+v8Output :: TMVar ByteString
+v8Output = unsafePerformIO newEmptyTMVarIO
+
+{-# NOINLINE isV8EncoderEnabled #-}
+isV8EncoderEnabled :: TMVar Bool
+isV8EncoderEnabled = unsafePerformIO newEmptyTMVarIO
+
+initV8Encoder :: Text -> IO ()
+initV8Encoder cmd = do
+  atomically $ putTMVar isV8EncoderEnabled True
+  forkIO $ command cmd v8Input v8Output
+  return ()
+
+encodeForSigning :: Bool -> ByteString -> IO (Either Text ByteString)
+encodeForSigning contentOrder arg = do
+  isEnabled <- atomically $ isEmptyTMVar isV8EncoderEnabled
+  if not isEnabled
+    then
+      return (error "external V8 byte string encoder not initialized")
+    else do
+      atomically $ putTMVar v8Input (cmd <> toS arg)
+      ret <- atomically $ takeTMVar v8Output
+      let ret' = Base64.decode (toS ret)
+      return $ mapLeft toS ret'
+ where
+  cmd = if contentOrder
+    then "y"
+    else "n"