{-# LANGUAGE DeriveGeneric, OverloadedStrings, FlexibleContexts #-}

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) }

-- | 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 :: GenericLink
	} 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 :: 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"

-- | 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 :: GenericLink
	, 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 :: PublicKey
	} 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