Source

HReddit / src / Navigation.hs

Full commit
{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}

module Navigation (startReddit) where

import Reddit
import Renderer
import RedditActions
import Formatter(isBetween, between, glob)

import Data.List (intercalate, isPrefixOf)
import Data.Char (isSpace, isDigit)
import Data.Maybe (fromMaybe, listToMaybe)

import Network.HTTP
import Network.Browser
import Network.URI

import Data.Time (getCurrentTime)
import System.IO (stdout, hFlush)
import System.Process (system)
import System.Console.ANSI
import System.Console.Haskeline
import Text.PrettyPrint.ANSI.Leijen (putDoc)

import Control.Monad.State
import Control.Monad.Error
import Control.Monad.IO.Class

import Control.Concurrent (threadDelay)


data RedditPage = Subreddit String
                | SearchResults String

data ReadingState = ReadingListing ArticleListing RedditPage
                  | ReadingComments  [(NestedLevel, Comment)] [(NestedLevel, Comment)] Article -- current and remaining nested Comments and the commented article
                  | NoState
                
data Command = GotoSubreddit String
             | GotoArticle ArticleIndex
             | OpenArticleURL ArticleIndex
             | OpenArticleDetails ArticleIndex
             | OpenCommentURL String
             | UpvoteArticle ArticleIndex
             | DownvoteArticle ArticleIndex
             | UnvoteArticle ArticleIndex
             | Search String
             | NextPage
             | GoBack
             | GoForward
             | Login String String
             | NoCommand
             | Exit
           
           
data NavigationState = NavigationState { curRState   :: ReadingState,
                                         backList    :: [ReadingState],
                                         forwardList :: [ReadingState],
                                         userInfo    :: Maybe UserInfo,
                                         cookies     :: [Cookie]
                                         }
                                         
initialNavState :: NavigationState
initialNavState = NavigationState NoState [] [] Nothing []


appendStateToHistory :: ReadingState -> NavigationState -> NavigationState
appendStateToHistory ns nav@(NavigationState{ curRState = cs, backList = bls }) = nav{ curRState = ns, backList = cs : bls, forwardList = [] }


modifyCurrentState :: ReadingState -> NavigationState -> NavigationState
modifyCurrentState ns nav = nav{ curRState = ns }


navigateBack :: NavigationState -> NavigationState
navigateBack nav@(NavigationState{ backList = [] }) = nav

navigateBack nav@(NavigationState{ curRState = cs,
                                   backList = ps : bs,
                                   forwardList = fls})
                                    | null bs   = nav
                                    | otherwise = nav{ curRState = ps,
                                                       backList = bs,
                                                       forwardList = cs : fls}
                                                               
                                                               
navigateForward :: NavigationState -> NavigationState
navigateForward nav@(NavigationState{ forwardList = [] }) = nav

navigateForward nav@(NavigationState{ curRState = cs, 
                                      backList = bls,
                                      forwardList = f: fs}) = nav{ curRState = f,
                                                                   backList = cs : bls,
                                                                   forwardList = fs}


updateNavCookies cs nav = nav{ cookies = cs }

             
instance MonadIO (BrowserAction conn) where
    liftIO = ioAction
   

type BrowserActionS = BrowserAction (HandleStream String)        


-- The R monad that manages state recording, configuration retrieving and error handling
type R = ErrorT String (StateT NavigationState BrowserActionS)


liftBrowser :: BrowserActionS a -> R a
liftBrowser = lift . lift


instance Requestable R where
    requestURL url = do
                         (uri, rsp) <- liftBrowser (request $ getRequest url)
                         return (uri, rspBody rsp)
                         
    postRequestURL url body = do
                                  let rqt0 = postRequest url
                                  let rqt1 = rqt0 { rqHeaders = mkHeader HdrContentType "application/x-www-form-urlencoded; charset=UTF-8" : [mkHeader HdrContentLength (show $ length body)] }
                                  let rqt = rqt1{ rqBody = body }
                                  (uri, rsp) <- liftBrowser (request rqt)
                                  cs <- liftBrowser getCookies
                                  modify $ updateNavCookies cs
                                  return $ (uri, rspBody rsp)


startReddit = do
                  setTitle "reddit: the front page of the internet"
                  runReddit (GotoSubreddit "") initialNavState


redditBrowserAction cs = setupCookieFilter >> supressBrowserLogging >> setCookies cs where
                                setupCookieFilter = setCookieFilter f 
                                                      where f _ c --  Cookie 'reddit_first' signals the user is the first time visitor, but it may interfere with the login session cookie
                                                             | ckName c == "reddit_first" = return False 
                                                             | otherwise = return True


                                supressBrowserLogging = setOutHandler (const $ return ())


runReddit :: Command -> NavigationState -> IO ()
runReddit command state = do
                               r <- browse $ redditBrowserAction (cookies state) >> runStateT (runErrorT (runCommand command)) state
                               case r of
                                   (Right Exit, _) -> return ()
                                   (Right newCommand, newState) -> runReddit newCommand newState
                                   otherwise -> return ()


parseCommand :: MonadError String m => String -> m Command
parseCommand s = let (_:as) = words s
                     argl         = unwords as in 
                         case words s of
                             "r":subreddit:_ -> return $ GotoSubreddit subreddit
                             "r":[]          -> return $ GotoSubreddit ""
                             "g":index:_     -> apply GotoArticle index
                             "open":[]       -> return $ OpenArticleURL 0
                             "open":arg:_ | isBetween "[" "]" argl -> return $ OpenCommentURL (between "[" "]" argl)
                                          | all isDigit arg        -> return $ OpenArticleURL (fromMaybe 0 (maybeRead arg))
                                          | otherwise              -> throwError "Invalid article index"
                             "a":index:_     -> return $ OpenArticleDetails (fromMaybe 0 (maybeRead index))
                             "a":[]          -> return $ OpenArticleDetails 0
                             "upvote":ind:_  -> apply UpvoteArticle ind
                             "upvote":[]     -> return $ UpvoteArticle 0
                             "downvote":i:_  -> apply DownvoteArticle i
                             "downvote":[]   -> return $ DownvoteArticle 0
                             "unvote":ind:_  -> apply UnvoteArticle ind
                             "unvote":[]     -> return $ UnvoteArticle 0
                             "back":_        -> return GoBack
                             "forward":_     -> return GoForward
                             "search":query  -> return $ Search (intercalate "+"  query)
                             []              -> return NextPage
                             "login":u:p:_   -> return $ Login u p
                             "login":_       -> throwError "Incomplete login command"
                             "exit":_        -> return Exit
                             otherwise -> throwError "Unknown command"
                             where maybeRead "" = Just 0
                                   maybeRead s  = case reads s of
                                                      [(x, trailing)] | all isSpace trailing -> Just x
                                                      otherwise                              -> Nothing

                                   apply cmd index = maybe (throwError "Invalid article index") (return . cmd) (maybeRead index)  
         
commandList = ["open", "upvote", "downvote", "unvote", "back", "forward", "search", "login", "exit"]


-- Popular subreddits
subredditList = ["3DS", "4chan", "adviceanimals", "android", "apple", "art", "askreddit", "askscience", "atheism", "aww", "beer", "bestof", "blog", "books", "business", "canada", "circlejerk", "coding", "cogsci", "comics", "conspiracy", "cooking", "creepy", "design", "diy", "doesanybodyelse", "earthporn", "economics", "entertainment", "environment", "explainlikeimfive", "fffffffuuuuuuuuuuuu", "firstworldproblems", "fitness", "food", "frugal", "funny", "gadgets", "gaming", "geek", "gifs", "gonewild", "guns", "happy", "haskell", "health", "history", "howto", "humor", "iama", "itookapicture", "kindle", "lgbt", "libertarian", "linux", "listentothis", "lolcats", "loseit", "malefashionadvice", "math", "minecraft", "movies", "music", "netsec", "news", "nsfw", "offbeat", "philosophy", "photography", "physics", "pics", "politics", "programming", "psychology", "reddit.com", "science", "scifi", "seduction", "self", "sex", "shutupandtakemymoney", "skeptic", "space", "sports", "starcraft", "technology", "tf2", "tldr", "todayilearned", "trees", "truereddit", "twoxchromosomes", "videos", "vim", "web_design", "webgames", "wikipedia", "woahdude", "worldnews", "worldpolitics", "wtf", "youshouldknow"]


autocompleteLine prev cur
                | prev == ""   = complete cur commandList
                | prev == " r" = complete cur subredditList
                | otherwise    = []
                    where complete str = map simpleCompletion . filter (str `isPrefixOf`)


waitForInputStr :: (MonadIO m, MonadException m) => ReadingState -> InputT m String
waitForInputStr rState = do
                             liftIO $ setCursorColumn 0
                             cmdStr <- getInputLine $ cmdprompt rState
                             return $ fromMaybe "" cmdStr
                             where cmdprompt rState = case rState of
                                                          ReadingListing _ (Subreddit "")  -> defaultPrompt
                                                          ReadingListing _ (Subreddit sub) -> sub ++ ">"
                                                          ReadingListing _ (SearchResults _) -> "results.search>"
                                                          ReadingComments  _ _ a -> "comments." ++ articelSub a ++ ">"
                                                          NoState                -> defaultPrompt
                                                          where defaultPrompt = "reddit>"


inputSettings :: MonadIO m => Settings m
inputSettings = Settings { historyFile = Nothing,
                           complete = completeWordWithPrev Nothing " \t" (\ prev cur -> return $ autocompleteLine prev cur),
                           autoAddHistory = True }


getUserInput :: ReadingState -> IO String
getUserInput readingState = runInputT inputSettings $ waitForInputStr readingState

						       
runCommand :: Command -> R Command
runCommand Exit    = return Exit;
runCommand command = do
                        execCommand command
                        readingState <- gets curRState
                        cmdStr <- liftIO $ getUserInput readingState
                        parseCommand cmdStr
                        `catchError` ( \ err -> do
                                                    liftIO $ putStrLn err
                                                    runCommand NoCommand)
                               


                     
                    
execCommand :: Command -> R ()
execCommand (GotoSubreddit subreddit) = do
                                            articleList <- downloadSubreddit subreddit ""
                                            modify (appendStateToHistory $ ReadingListing articleList (Subreddit subreddit))
                                            liftIO $ displayArticles (listing articleList)
                                            
execCommand (Search query) = do
                                 articleList <- downloadSearchResults query ""
                                 modify (appendStateToHistory $ ReadingListing articleList (SearchResults query))
                                 liftIO $ displayArticles (listing articleList)


execCommand (GotoArticle index) = do
                                      readingState <- gets curRState
                                      case readingState of
                                          ReadingListing articleList _ -> do 
                                                                              a <- lookupArticle index
                                                                              comments <- downloadComments (articleLink a)
                                                                              liftIO $ displayDetailArticle a
                                                                              let (ccs, ncs) = splitAt 4 (serialiseComments 0 comments)                                                                       
                                                                              liftIO $ displayComments ccs
                                                                              modify (appendStateToHistory $ ReadingComments ccs ncs a)
                                                                           
                                          otherwise -> throwError "Can't go to any article from here"

execCommand (OpenArticleURL index)  = do
                                          a <- lookupArticle index
                                          startBrowser (articleURL a)
                                       
execCommand (OpenArticleDetails index)  = do
                                              a <- lookupArticle index
                                              liftIO $ displayDetailArticle a


execCommand (OpenCommentURL globPat) = do
                                           readingState <- gets curRState
                                           case readingState of
                                               ReadingComments cs _ _ -> do
                                                                             let err = "Can't find any link in the current comment page that matches the given glob pattern."
                                                                             url <- lookupFM (glob globPat) err (concat $ map (commentLinks . snd) cs)
                                                                             startBrowser url
                                               otherwise              -> throwError "Can't open comment link from here"



execCommand (UpvoteArticle index) = do
                                        article <- lookupArticle index
                                        user    <- gets userInfo
                                        voteArticle user (Upvote article)

execCommand (DownvoteArticle index) = do
                                        article <- lookupArticle index
                                        user    <- gets userInfo
                                        voteArticle user (Downvote article)

execCommand (UnvoteArticle index) = do
                                        article <- lookupArticle index
                                        user    <- gets userInfo
                                        voteArticle user (Neutral article)

execCommand NextPage = do
                           readingState <- gets curRState
                           case readingState of
                                ReadingComments _ cs a -> do
                                                              let (ccs, ncs) = splitAt 6 cs
                                                              liftIO $ displayComments ccs
                                                              modify (modifyCurrentState $ ReadingComments ccs ncs a)
                                ReadingListing articleList rp -> do
                                                                  nextPage <- fmap (updateArticleListingIndices articleList) $ downloadNextPage articleList rp
                                                                  modify (appendStateToHistory $ ReadingListing nextPage rp)
                                                                  liftIO $ displayArticles (listing nextPage)
                                                                  where downloadNextPage al (Subreddit sub) = downloadSubreddit sub (pageAnchor al)
                                                                        downloadNextPage al (SearchResults kwords) = downloadSearchResults kwords (pageAnchor al)
                             
execCommand GoBack = do
                         navState <- get
                         let prevNavState = navigateBack navState
                         put prevNavState
                         liftIO $ displayContent (curRState prevNavState)
                              
execCommand GoForward = do
                            navState <- get
                            let nextNavState = navigateForward navState
                            put nextNavState
                            liftIO $ displayContent (curRState nextNavState)

execCommand (Login user passwd) = do
                                      result <- loginReddit user passwd
                                      case result of
                                          Just userInfo -> liftIO (putStrLn $ "Successfully logged in!\tWelcome back " ++ userName userInfo ++ "!") >>
                                                           modify (\ navState -> navState{ userInfo = Just userInfo })
                                          Nothing       -> modify (\ navState -> navState{ userInfo = Nothing }) >>
                                                           liftIO (putStrLn "Failed to login!")
                              
execCommand NoCommand = return ()


startBrowser ::  MonadIO m => String -> m ()
startBrowser url = liftIO $ system ("start " ++ url) >> return ()


lookupArticle :: ArticleIndex -> R Article
lookupArticle index = do
                          readingState <- gets curRState
                          case readingState of
                              ReadingComments _ _ a        -> return a
                              ReadingListing articleList _ -> lookupM index "Invalid article number" (listing articleList) 
                              otherwise                    -> throwError "Error"


lookupM :: (Monad m, Eq k) => k -> String -> [(k, e)] -> m e
lookupM k err ls = maybe (fail err) return (lookup k ls)


lookupFM :: (Monad m) => (a -> Bool) -> String -> [(a, b)] -> m b
lookupFM f err ls  = maybe (fail err) (return . snd) (listToMaybe $ filter (f . fst) ls)


displayContent (ReadingComments pcs _ _)   = displayComments pcs
displayContent (ReadingListing articleList _) = displayArticles (listing articleList)
displayContent NoState = return ()                            
              
              
displayArticles articles = do
                               cUTC <- getCurrentTime
                               putStrLn (replicate 60 '*') 
                               mapM_ (putDoc . articleToDoc cUTC) articles
                               
                               
displayDetailArticle article = do
                                   cUTC <- getCurrentTime
                                   putStrLn (replicate 80 '*')
                                   putDoc $ detailArticleToDoc cUTC article


displayComments [] = return ()
displayComments cs = do 
                         cUTC <- getCurrentTime
                         cursorUpLine 1 >> clearLine -- Clear the command prompt e.g. reddit>_
                         putStrLn (replicate 60 '-') -- Display the page delimiter                                       
                         putDoc $ commentsToDoc cUTC cs