From 41cde99ec6189dbecca6803a5aa4f6f18142e8ba Mon Sep 17 00:00:00 2001 From: Haskell Guy Date: Tue, 26 May 2020 13:07:50 +0200 Subject: initial commit --- src/Ssb/Feed.hs | 342 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 342 insertions(+) create mode 100644 src/Ssb/Feed.hs (limited to 'src/Ssb/Feed.hs') 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" -- cgit v1.2.3