module Ssb.Types.Message (
Signature,
Message(..),
messageLink,
AnyContent(..),
contentType,
parseMessage,
narrowParse,
PrivateContent(..),
Post(..),
UserLink(..),
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 Control.Monad
import qualified Data.Text as T
import qualified Data.Vector as V
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 Functor Message where
fmap f m = m { content = f (content m) }
messageLink :: Hashed (Message a) -> MessageLink
messageLink hm = MessageLink (hashOf hm)
parseMessage :: FromJSON a => L.ByteString -> Maybe (Hashed (Message a))
parseMessage b = calcHashed b hash decode
data AnyContent = AnyContent { fromAnyContent :: Value }
deriving (Show, Eq)
instance FromJSON AnyContent where
parseJSON = pure . AnyContent
contentType :: Message AnyContent -> T.Text
contentType = fromMaybe ""
. parseMaybe (withObject "AnyContent" (.: "type"))
. fromAnyContent
. content
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 :: [MessageLink]
, recps :: [UserLink]
, mentions :: [UserLink]
} deriving (Show, Eq, Generic)
instance FromJSON Post where
parseJSON = parseMessageType "post" $ withObject "Post" $ \o -> Post
<$> o .: "text"
<*> o .:? "channel"
<*> parseroot o
<*> parsebranch o
<*> (o .:? "recps" .!= mempty)
<*> parsementions o
where
parseroot o = join <$> explicitParseFieldMaybe
(pure . parseMaybe parseJSON)
o "root"
parsebranch o = do
v <- explicitParseFieldMaybe
(arrayOrSingleton (parseMaybe parseJSON))
o "branch"
.!= mempty
return (catMaybes v)
parsementions o = do
v <- explicitParseFieldMaybe
(arrayOrSingleton (parseMaybe parseJSON))
o "mentions"
.!= mempty
return (catMaybes v)
arrayOrSingleton :: (Value -> a) -> Value -> Parser [a]
arrayOrSingleton p v@(Object _) = pure [p v]
arrayOrSingleton p v@(String _) = pure [p v]
arrayOrSingleton p (Array v) = pure (map p (V.toList v))
arrayOrSingleton _ _ = fail "expected Array or Object"
data UserLink = UserLink
{ userLink :: Link
, userName :: Maybe T.Text
} deriving (Show, Eq, Generic)
instance FromJSON UserLink where
parseJSON = parseStrippingPrefix "user"
data About = About
{ about :: Link
, name :: Maybe T.Text
, image :: Maybe AboutImage
, description :: Maybe T.Text
} 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 o@(Object _) = parseStrippingPrefix "aboutimage" o
parseJSON s@(String _) = AboutImage
<$> parseJSON s
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
parseJSON invalid = typeMismatch "AboutImage" invalid
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 :: Link
, 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 :: FeedLink
} 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