{-# 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) = "%" <> decodeUtf8 (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 . encodeUtf8 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) = decodeUtf8 (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 . encodeUtf8 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\": " <> "\"" <> encodeUtf8 (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 <> arg) ret <- atomically $ takeTMVar v8Output let ret' = Base64.decode ret return $ mapLeft toS ret' where cmd = if contentOrder then "y" else "n"