path: root/src/Ssb/Feed.hs

{-# 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"