~jackwines/discourse-tui

ref: 9a30b6e7282224a8bfba319347d36dd68aeddcd7 discourse-tui/src/Main.hs -rw-r--r-- 7.2 KiB
9a30b6e7 — Jack Wines selected posts have a better styed marker 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Monad.IO.Class
import Brick
import Network.HTTP.Simple
import Data.Aeson
import qualified Cursor.List.NonEmpty as NE
import Cursor.Simple.List.NonEmpty (NonEmptyCursor)
import qualified Cursor.Simple.List.NonEmpty as SNE
import Graphics.Vty.Input.Events
import Graphics.Vty.Attributes
import Data.Maybe
import Brick.Widgets.Border
import qualified Data.IntMap.Strict as M
import Brick.Widgets.List
import qualified Data.Vector as V
import qualified Data.Text as T
import Text.Pandoc
import Text.Pandoc.Writers.CommonMark
import Text.Pandoc.Readers.HTML
import System.Environment
import Types
import System.Exit
import Control.Lens


helpMessage = "Usage: discourse-tui url \n Ex: discourse-tui http://discourse.haskell.org"

parseArgs :: IO String
parseArgs = do
    args <- getArgs
    if null args || (head args) == "--help"
        then die helpMessage
        else return $ head args

main :: IO ()
main = do
    baseUrl <- parseArgs
    initialState <- getTuiState baseUrl
    endState <- defaultMain tuiApp initialState
    return ()

-- initialize the TuiState with the list of topics and catagories
getTuiState :: String -> IO TuiState
getTuiState baseUrl = do
    topicsRequest <- parseRequest (baseUrl ++ "/latest.json")
    categoriesRequest <- parseRequest (baseUrl ++ "/categories.json")
    (TopicResponse users topicList) <- getResponseBody <$> httpJSON topicsRequest
    categoriesResp <- getResponseBody <$> httpJSON categoriesRequest
    return TuiState {
        _posts = Nothing,
        _topics = list "contents" (V.fromList topicList) topicHeight,
        _userMap = M.fromList . map (\x -> (x^.userId, x)) $ users,
        _categoryMap = M.fromList . map (\x -> (x^.categoryId, x)) $ categoriesResp^.categories,
        _baseURL = baseUrl,
        _singlePostView = False
                    }

-- the help bar at the bottom
helpBar :: Widget String
helpBar = withAttr "bar" . str $ "arrow keys -> move | left right -> read replies/full post | q to quit"

-- get the posts for the current topic
getPosts :: TuiState -> IO (List String Post)
getPosts ts = do
    let (Just selectedTopicID) = view (_2 . topicId) <$> listSelectedElement (ts ^. topics)
    postsRequest <- parseRequest $ mconcat [ts^.baseURL, "/t/", show selectedTopicID, ".json"]
    (PostResponse posts') <- getResponseBody <$> httpJSON postsRequest
    posts <- mapM postToPandoc posts'
    return $ list "posts" (V.fromList posts) 10

postToPandoc :: Post -> IO Post
postToPandoc post = do
    newContents <- toMarkdown $ post ^. contents
    return $ post & contents .~ newContents



tuiApp :: App TuiState e ResourceName
tuiApp =
    App
        { appDraw = drawTui
        , appChooseCursor = showFirstCursor
        , appHandleEvent = handleTuiEvent
        , appStartEvent = pure
        , appAttrMap = const $ attrMap mempty [("title", withStyle defAttr bold), ("pinned", fg green), ("selected", bg yellow), ("OP", fg blue), ("rest", defAttr), ("bar", fg yellow)]
        }

toMarkdown :: String -> IO String
toMarkdown s = do
    result <- runIO $ do
        doc <- readHtml def (T.pack s)
        writeCommonMark def doc
    rst <- handleError result
    return $ T.unpack rst

-- draws the entire TuiState
-- this pattern matches the topic list
drawTui :: TuiState -> [Widget ResourceName]
drawTui (TuiState scrollable Nothing userMap categoryMap _ _) = (:[]) $ (renderList drawTopic True $ scrollable) <=> helpBar
    where
        drawTopic selected (Topic _ categoryId title likeCount postsCount posters pinned)
                        = border
                        . (if pinned   then  withAttr "pinned"   else id)
                        . padRight Max
                        $ (likes <+> title') <=> hBox [category, postsCount', posters']
            where
                likes :: Widget ResourceName
                likes = (if selected then  withAttr "selected" else id)
                      . padRight (Pad 1)
                      . hLimit 4
                      . padRight Max
                      . str
                      . show
                      $ likeCount

                title' :: Widget ResourceName
                title' = withAttr "title" . str $ title

                postsCount' :: Widget ResourceName
                postsCount' = padLeft (Pad 5)
                            . str
                            . ("posts: " ++)
                            . show
                            $ postsCount

                posters' :: Widget ResourceName
                posters' = padLeft (Pad 5)
                       . hBox
                       . mapFst (withAttr "OP") (withAttr "rest")
                       . showList
                       . map (\x -> view userName $ userMap M.! (x ^. posterId))
                       $ posters

                category :: Widget ResourceName
                category = padLeft (Pad 5) . str . view categoryName $ categoryMap M.! categoryId

                showList :: [String] -> [Widget ResourceName]
                showList s = map str $ (map (++ " ") . init $ s) ++ [last s]

-- this pattern matches the post list
drawTui (TuiState _ (Just posts) _ _ _ False)
    = (:[])
    $ (renderList drawPost True $ posts)
    <=> helpBar
    where
        drawPost selected (Post id username' contents score')
            = border'
            $ withAttr (if selected then "selected" else "")
              (hLimit 4 . padRight Max . str . show $ score') 
            <+> (userName''
            <=> contents')
            where
                userName'' = withAttr "OP" . str $ username'
                contents' = strWrap contents
                border' = border
                        . vLimit 8
                        . padBottom Max
                        . padRight  Max

drawTui (TuiState _ (Just posts) _ _ _ True) = (:[]) $ case listSelectedElement posts of
    (Just (_, post)) -> (withAttr "OP" . str $ post ^. opUserName)
     <=> padBottom Max (str $ post ^. contents) <=> helpBar
    Nothing -> str "something went wrong"

mapFst :: (a -> a) -> (a -> a) ->  [a] -> [a]
mapFst fn fn' (x:xs) = (fn x) : (map fn' xs)

-- handles key presses. TODO: clean
handleTuiEvent :: TuiState -> BrickEvent String e -> EventM String (Next TuiState)
handleTuiEvent tui (VtyEvent (EvKey (KChar 'q') _)) = halt tui
handleTuiEvent (TuiState topics (Just list) usrMap catMap url singlePostView) (VtyEvent (EvKey KRight _)) = continue $ TuiState topics (Just list) usrMap catMap url (not singlePostView)
handleTuiEvent (TuiState topics (Just list) usrMap catMap url True) (VtyEvent (EvKey _ _)) = continue $ TuiState topics (Just list) usrMap catMap url False
handleTuiEvent tui (VtyEvent (EvKey KRight  _)) = do
    posts' <- liftIO $ getPosts tui
    continue $ tui & posts .~ (Just posts')

handleTuiEvent tui (VtyEvent (EvKey KLeft   _)) = continue $ tui & posts .~ Nothing
handleTuiEvent (TuiState list Nothing usrMap catMap url spv) ev = scrollHandler (\x -> TuiState x Nothing usrMap catMap url spv) list ev
handleTuiEvent (TuiState topics (Just list) usrMap catMap url spv) ev = scrollHandler (\x -> TuiState topics (Just x) usrMap catMap url spv) list ev

scrollHandler restoreTuiState list (VtyEvent ev) = continue . restoreTuiState =<< handler
    where
        handler = handleListEvent ev list