4r/app/Api/Types.hs

103 lines
3.9 KiB
Haskell

{-# LANGUAGE Strict #-}
module Api.Types ( GetSections(GetSections)
, Section(..)
, GetTopics(GetTopics)
, TopicInfo(..)
, GetTopic(..)
, Topic(..)
, ThreadHead(..)
, ThreadPost(..)
) where
import Relude
import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), withObject)
import Data.HashMap.Strict qualified as M
import Polysemy.Commonmark.AST (commonmark)
import Polysemy.Output.IO
import Polysemy.Sgr
import Color.Print
import System.Console.ANSI
import Web.FormUrlEncoded (Form(Form), ToForm(toForm))
import Color.Utils
data GetSections = GetSections
instance ToForm GetSections where
toForm GetSections = Form $ M.fromList [("type", ["sections"]), ("key", ["anon"])]
data Section = Section { id :: Integer
, thread_group_name, description :: Text
}
deriving stock (Generic, Show)
instance NFData Section
instance FromJSON Section
data GetTopics = GetTopics
instance ToForm GetTopics where
toForm GetTopics = Form $ M.fromList [("type", ["threads"]), ("key", ["anon"])]
data TopicInfo = TopicInfo { id, group_id, nbr_ansfers :: Integer
, thrname, date, name, last_activity_date, last_activity_user :: Text
}
deriving stock (Generic, Show)
instance NFData TopicInfo
instance FromJSON TopicInfo
data GetTopic = GetTopic { topic_id :: Integer }
instance ToForm GetTopic where
toForm GetTopic {topic_id} = Form $ M.fromList [ ("type", ["topic"])
, ("key", ["anon"])
, ("id", [show topic_id])
]
data Topic = Topic { thread :: ThreadHead
, post :: [ThreadPost]
}
deriving stock (Generic, Show)
instance NFData Topic
instance FromJSON Topic
instance PrintColor Topic where
printColor Topic{thread, post} =
sequenceA_ $ intersperse (putTextLnO "") (printColor <$> threadHeadToPost thread : post)
data ThreadHead = ThreadHead { info :: TopicInfo
, message :: Text
}
deriving stock (Generic, Show)
instance NFData ThreadHead
instance FromJSON ThreadHead where
parseJSON = withObject "ThreadHead" \o -> ThreadHead <$> parseJSON (Object o)
<*> o .: "message"
threadHeadToPost :: ThreadHead -> ThreadPost
threadHeadToPost ThreadHead{info, message} = ThreadPost { id = info.id
, topic_id = info.id
, name = info.name
, date = info.date
, message
}
data ThreadPost = ThreadPost { id, topic_id :: Integer
, name, date, message :: Text
}
deriving stock (Generic, Show)
instance NFData ThreadPost
instance FromJSON ThreadPost
instance PrintColor ThreadPost where
printColor ThreadPost{id = post_id, name, date, message} = do
withSgr [ SetPaletteColor Foreground (textColor name)
, SetConsoleIntensity BoldIntensity
-- , SetSwapForegroundBackground True
] do
putTextO name
withSgr [SetColor Foreground Dull White] do
putTextLnO $ " " <> date <> " #" <> show post_id
case commonmark "<message>" message of
Right block -> printColor block
Left err -> withSgr [SetColor Foreground Vivid Red] do
putTextLnO $ "Error parsing commonmark: " <> show err
putTextLnO message