module Ssb.Types.Message (
Signature,
HashType,
Message(..),
AnyContent(..),
narrowParse,
PrivateContent(..),
Post(..),
Mention(..),
About(..),
AboutImage(..),
Contact(..),
Vote(..),
Pub(..),
parseMessageType
) where
import Ssb.Types.Key
import Ssb.Types.Link
import GHC.Generics
import Data.Aeson
import Data.Aeson.Types
import Data.Int (Int64)
import qualified Data.Text as T
import Data.Maybe
import Data.List
import Data.Char
import Control.Applicative
import Prelude hiding (sequence)
type Signature = String
type HashType = 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) }
data AnyContent = AnyContent { fromAnyContent :: Value }
deriving (Show, Eq)
instance FromJSON AnyContent where
parseJSON = pure . AnyContent
narrowParse :: FromJSON a => Message AnyContent -> Parser (Message a)
narrowParse m = do
c <- parseJSON (fromAnyContent (content m))
return $ m { content = c }
data PrivateContent = PrivateContent T.Text
deriving (Show, Eq)
instance FromJSON PrivateContent where
parseJSON = withText "PrivateContent" (pure . PrivateContent)
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)
data Mention = Mention
{ mentionLink :: GenericLink
} deriving (Show, Eq, Generic)
instance FromJSON Mention where
parseJSON = parseStrippingPrefix "mention"
data About = About
{ about :: GenericLink
, 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"
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
data Vote = Vote
{ voteLink :: GenericLink
, voteValue :: Int
, voteExpression :: Maybe T.Text
} deriving (Show, Eq, Generic)
instance FromJSON Vote where
parseJSON = parseMessageType "vote" $ withObject "Vote" $ \o -> do
v <- o .: "vote"
Vote
<$> v .: "link"
<*> (v .: "value" <|> stringvalue v)
<*> v .:? "expression"
where
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"
data Pub = Pub
{ pubHost :: T.Text
, pubPort :: Int
, pubKey :: PublicKey
} deriving (Show, Eq, Generic)
instance FromJSON Pub where
parseJSON = parseMessageType "pub" $ withObject "Pub" $ \o -> do
v <- o .: "address"
parseStrippingPrefix "pub" v
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
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