4r/app/Api/Types.hs

92 lines
3.3 KiB
Haskell

{-# LANGUAGE Strict #-}
module Api.Types ( GetSections(GetSections)
, Section(..)
, GetTopics(GetTopics)
, TopicInfo(..)
, GetTopic(..)
, Topic(..)
, ThreadHead(..)
, ThreadPost(..)
) where
import Relude
import Commonmark (commonmark)
import Data.Aeson (FromJSON(parseJSON), Value(Object), (.:), withObject)
import Data.HashMap.Strict qualified as M
import Polysemy.Commonmark.AST (Block, Inline)
import Polysemy.Output.IO
import Polysemy.Sgr
import PrintColor
import System.Console.ANSI
import Web.FormUrlEncoded (Form(Form), ToForm(toForm))
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
-- TODO: print thread head!
printColor Topic{post} = sequenceA_ $ intersperse (putTextLnO "") (printColor <$> 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"
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{name, date, message} = do
withSgr [SetColor Foreground Vivid Red] do
putTextO $ name <> " "
withSgr [SetColor Foreground Dull White] do
putTextLnO date
case commonmark @Inline @Block "<message>" message of
Right block -> printColor block
Left err -> withSgr [SetColor Foreground Vivid Red] do
putTextLnO $ "Error parsing commonmark: " <> show err
putTextLnO message