{-# LANGUAGE DeriveGeneric, OverloadedStrings, FlexibleContexts #-}
module Ssb.Types.Message (
Signature,
Message(..),
messageLink,
AnyContent(..),
parseMessage,
narrowParse,
PrivateContent(..),
Post(..),
Mention(..),
About(..),
AboutImage(..),
Contact(..),
Vote(..),
Pub(..),
parseMessageType
) where
import Ssb.Types.Link
import Ssb.Types.Hash
import GHC.Generics
import Data.Aeson
import Data.Aeson.Types
import Data.Int (Int64)
import Data.Maybe
import Data.List
import Data.Char
import Control.Applicative
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as L
import Prelude hiding (sequence)
type Signature = String
data Message a = Message
{ previous :: Maybe MessageLink
, author :: FeedLink
, sequence :: Int64
, timestamp :: Float
, hash :: HashType
, content :: a
, signature :: Signature
} deriving (Show, Eq, Generic)
instance FromJSON a => FromJSON (Message a)
instance ToJSON a => ToJSON (Message a)
instance Functor Message where
fmap f m = m { content = f (content m) }
messageLink :: Hashed (Message a) -> MessageLink
messageLink hm = MessageLink (hashOf hm)
-- | Parses a JSON formatted message, and accompanies it with the
-- hash that was originally used for the message.
parseMessage :: FromJSON a => L.ByteString -> Maybe (Hashed (Message a))
parseMessage b = calcHashed b hash decode
-- | Parsing a Message AnyContent allows parsing the message envelope,
-- regardless of the type of content in the message.
data AnyContent = AnyContent { fromAnyContent :: Value }
deriving (Show, Eq)
instance FromJSON AnyContent where
parseJSON = pure . AnyContent
-- | For best efficiency when the type of a message is not known,
-- first parse to a Message AnyContent, and then use this function
-- with `parseMaybe` or `parseEither` to try to further parse that
-- to different message types.
--
-- For example:
--
-- > Just somemsg = decode b :: Maybe Message AnyContent
-- > case parseMaybe narrowParse somemsg :: Maybe (Message Post) of
-- > Just postmsg -> ...
-- > Nothing -> case parseMaybe narrowParse somemsg :: Maybe (Message PrivateContent) of
-- > Just privmsg -> ...
-- > Nothing -> ...
narrowParse :: FromJSON a => Message AnyContent -> Parser (Message a)
narrowParse m = do
c <- parseJSON (fromAnyContent (content m))
return $ m { content = c }
-- | A message with encrypted content.
data PrivateContent = PrivateContent T.Text
deriving (Show, Eq)
-- Any message that has a content that is a string, rather than a JSON
-- object, is an encrypted message.
instance FromJSON PrivateContent where
parseJSON = withText "PrivateContent" (pure . PrivateContent)
-- | A post is a text-based message, for a public or private audience.
-- It can be a reply to other posts.
data Post = Post
{ text :: T.Text
, channel :: Maybe T.Text
, root :: Maybe MessageLink
, branch :: Maybe MessageLink
, recps :: Maybe [FeedLink]
, mentions :: Maybe [Mention]
} deriving (Show, Eq, Generic)
instance FromJSON Post where
parseJSON = parseMessageType "post" (genericParseJSON defaultOptions)
-- | A generic reference to other feeds, entities, or blobs
data Mention = Mention
{ mentionLink :: Link
} deriving (Show, Eq, Generic)
instance FromJSON Mention where
parseJSON = parseStrippingPrefix "mention"
-- | About-messages set attributes about someone or something.
-- They can be used to set a name or picture for users, files, or messages.
-- However, they're most commonly published about users.
data About = About
{ about :: Link
, name :: Maybe T.Text
, image :: Maybe AboutImage
} deriving (Show, Eq, Generic)
instance FromJSON About where
parseJSON = parseMessageType "about" (genericParseJSON defaultOptions)
data AboutImage = AboutImage
{ aboutImageLink :: BlobLink
, aboutImageSize :: Maybe Int
, aboutImageType :: Maybe T.Text
, aboutImageWidth :: Maybe Int
, aboutImageHeight :: Maybe Int
} deriving (Show, Eq, Generic)
instance FromJSON AboutImage where
parseJSON = parseStrippingPrefix "aboutimage"
-- | Contact-messages determine who you are following or blocking.
data Contact = Contact
{ contact :: FeedLink
, following :: Bool
, blocking :: Bool
} deriving (Show, Eq, Generic)
instance FromJSON Contact where
parseJSON = parseMessageType "contact" $
withObject "Contect" $ \o -> Contact
<$> o .: "contact"
<*> o .:? "following" .!= False
<*> o .:? "blocking" .!= False
-- | Vote-messages signal approval about someone or something.
-- Votes can be on users, messages, or blobs.
data Vote = Vote
{ voteLink :: Link
, voteValue :: Int
, voteExpression :: Maybe T.Text
} deriving (Show, Eq, Generic)
instance FromJSON Vote where
parseJSON = parseMessageType "vote" $ withObject "Vote" $ \o -> do
-- For some reason the JSON wraps the vote in another object.
v <- o .: "vote"
Vote
<$> v .: "link"
<*> (v .: "value" <|> stringvalue v)
<*> v .:? "expression"
where
-- It's not uncommon for the value to be a string containing a
-- number, although it's supposed to be a plain number.
stringvalue v = do
s <- v .: "value" :: Parser T.Text
case s of
"1" -> return 1
"0" -> return 0
"-1" -> return (-1)
_ -> fail "unknown vote value"
-- Pub-messages announce the address, port, and public key of pubs.
-- They are automatically published by Scuttlebot after successfully
-- using an invite to a pub.
data Pub = Pub
{ pubHost :: T.Text
, pubPort :: Int
, pubKey :: FeedLink
} deriving (Show, Eq, Generic)
instance FromJSON Pub where
parseJSON = parseMessageType "pub" $ withObject "Pub" $ \o -> do
-- For some reason the JSON wraps the pub in another object.
v <- o .: "address"
parseStrippingPrefix "pub" v
-- | Parse the content of a message using the provided Parser,
-- which will typically be genericParseJSON defaultOptions.
--
-- The "type" field must contain the specified Text for the parse to succeed.
parseMessageType :: T.Text -> (Value -> Parser a) -> Value -> Parser a
parseMessageType ty parser v@(Object o) = do
t <- o .: "type"
if t == ty
then parser v
else fail $ "wrong message type " ++ T.unpack t ++ " (expected " ++ T.unpack ty ++ ")"
parseMessageType ty _ invalid = typeMismatch (T.unpack ty) invalid
-- | Parse, stripping a common prefix from the haskell record names.
parseStrippingPrefix :: (Generic a, GFromJSON Zero (Rep a)) => String -> Value -> Parser a
parseStrippingPrefix prefix =
genericParseJSON $ defaultOptions { fieldLabelModifier = f }
where
f s = fromMaybe s $ stripPrefix prefix $ map toLower s