module Reddit.Types.Comment where
import Reddit.Parser
import Reddit.Types.Listing
import Reddit.Types.Post hiding (author)
import Reddit.Types.Reddit
import Reddit.Types.Subreddit
import Reddit.Types.Thing
import Reddit.Types.User
import Reddit.Utilities
import Control.Applicative
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Monoid
import Data.Text (Text)
import Data.Traversable
import Network.API.Builder.Query
import Prelude
import qualified Data.Text as Text
import qualified Data.Vector as Vector
newtype CommentID = CommentID Text
deriving (Show, Read, Eq, Ord)
instance FromJSON CommentID where
parseJSON (String s) =
CommentID <$> stripPrefix commentPrefix s
parseJSON _ = mempty
instance Thing CommentID where
fullName (CommentID cID) = Text.concat [commentPrefix, "_", cID]
instance ToQuery CommentID where
toQuery k v = [(k, fullName v)]
instance FromJSON (POSTWrapped CommentID) where
parseJSON (Object o) = do
ts <- (o .: "json") >>= (.: "data") >>= (.: "things")
case Vector.toList ts of
[v] -> POSTWrapped <$> (v .: "data" >>= (.: "id"))
_ -> mempty
parseJSON _ = mempty
data CommentReference = Reference Integer [CommentID]
| Actual Comment
deriving (Show, Read, Eq)
instance FromJSON CommentReference where
parseJSON v@(Object o) = do
k <- o .: "kind"
case k of
String "t1" -> Actual <$> parseJSON v
String "more" ->
Reference <$> ((o .: "data") >>= (.: "count"))
<*> ((o .: "data") >>= (.: "children"))
_ -> mempty
parseJSON _ = mempty
instance FromJSON (POSTWrapped [CommentReference]) where
parseJSON (Object o) = do
cs <- (o .: "json") >>= (.: "data") >>= (.: "things")
POSTWrapped <$> parseJSON cs
parseJSON _ = mempty
isActual :: CommentReference -> Bool
isActual (Actual _) = True
isActual _ = False
isReference :: CommentReference -> Bool
isReference (Reference _ _) = True
isReference _ = False
data Comment = Comment { commentID :: CommentID
, score :: Maybe Integer
, subredditID :: SubredditID
, subreddit :: SubredditName
, gilded :: Integer
, saved :: Bool
, author :: Username
, authorFlairCSSClass :: Maybe Text
, authorFlairText :: Maybe Text
, body :: Text
, bodyHTML :: Text
, replies :: Listing CommentID CommentReference
, created :: UTCTime
, edited :: Maybe UTCTime
, parentLink :: PostID
, inReplyTo :: Maybe CommentID }
deriving (Show, Read, Eq)
instance Thing Comment where
fullName c = fullName (commentID c)
instance FromJSON Comment where
parseJSON (Object o) = do
o `ensureKind` commentPrefix
d <- o .: "data"
Comment <$> d .: "id"
<*> d .:? "score"
<*> d .: "subreddit_id"
<*> d .: "subreddit"
<*> d .: "gilded"
<*> d .: "saved"
<*> d .: "author"
<*> d .:? "author_flair_css_class"
<*> d .:? "author_flair_text"
<*> (unescape <$> d .: "body")
<*> d .: "body_html"
<*> d .: "replies"
<*> (posixSecondsToUTCTime . fromInteger <$> d .: "created_utc")
<*> ((fmap (posixSecondsToUTCTime . fromInteger) <$> d .: "edited") <|> pure Nothing)
<*> (parseJSON =<< d .: "link_id")
<*> (d .:? "parent_id" >>= \v -> traverse parseJSON v <|> pure Nothing)
parseJSON _ = mempty
instance FromJSON (POSTWrapped Comment) where
parseJSON (Object o) = do
ts <- (o .: "json") >>= (.: "data") >>= (.: "things")
case Vector.toList ts of
[c] -> POSTWrapped <$> parseJSON c
_ -> mempty
parseJSON _ = mempty
treeSubComments :: CommentReference -> [CommentReference]
treeSubComments a@(Actual c) = a : concatMap treeSubComments ((\(Listing _ _ cs) -> cs) $ replies c)
treeSubComments (Reference _ rs) = map (\r -> Reference 1 [r]) rs
isDeleted :: Comment -> Bool
isDeleted = (== Username "[deleted]") . author
data PostComments = PostComments Post [CommentReference]
deriving (Show, Read, Eq)
instance FromJSON PostComments where
parseJSON (Array a) =
case Vector.toList a of
postListing:commentListing:_ -> do
Listing _ _ [post] <- parseJSON postListing :: Parser (Listing PostID Post)
Listing _ _ comments <- parseJSON commentListing :: Parser (Listing CommentID CommentReference)
return $ PostComments post comments
_ -> mempty
parseJSON _ = mempty
type CommentListing = Listing CommentID Comment
commentPrefix :: Text
commentPrefix = "t1"