BST.hs

module BST where
import Data.Time
import Control.Concurrent.STM

data Account = Account { aemail :: String
                       , apass :: String
                       , auid :: String }
               deriving (Show)
                        
instance Ord Account where
  compare a b = (aemail a) `compare` (aemail b)
instance Eq Account where
  (==) a b = (auid a) == (auid b)

data Feed = Feed { furl :: String
                 , fbackground :: String }
            deriving (Show)
instance Ord Feed where
  compare a b = (furl a) `compare` (furl b)
instance Eq Feed where
  (==) a b = (furl a) == (furl b)

data Content = Content { cupdated :: UTCTime
                       , ccontent :: String
                       , clink :: String
                       , ctitle :: String
                       , cfavorite :: Bool
                       , cbackground :: String }
               deriving (Show)
instance Ord Content where
  compare a b = (cupdated a) `compare` (cupdated b)
instance Eq Content where
  (==) a b = (cupdated a) == (cupdated b)

data AppState =
  AppState { feeds :: BTree Feed
           , content :: BTree Content
           , accounts :: BTree Account }
  deriving(Show)
          

empty_state :: AppState
empty_state = AppState End End End





add_feed :: Feed -> TVar AppState -> IO ()
add_feed fd as = do
  _ <- atomically $ do
    (AppState f c a) <- readTVar as
    writeTVar as (AppState (insert fd f) c a)
  return ()






data BTree a = End
             | Node a (BTree a) (BTree a)
             deriving (Show,Eq,Ord)

blank :: a -> BTree a
blank a = Node a End End

insert :: Ord a => a -> BTree a -> BTree a
insert a End = blank a
insert a (Node v lf ri)
  | a <= v = Node v (insert a lf) ri
  | otherwise = Node v lf (insert a ri)

search :: (Ord a) => a -> BTree a -> Maybe a
search _ End = Nothing
search tos (Node val lef ri)
  | tos == val = Just val
  | tos < val = search tos lef
  | tos > val = search tos ri
search _ _ = Nothing

pick :: (a -> Bool) -> BTree a -> [a]
pick _ End = []
pick tos (Node val lef ri)
  | (tos val) == True =
    (pick tos lef) ++ [val] ++ (pick tos ri)
  | otherwise = (pick tos lef) ++ (pick tos ri)

transform :: (a -> a) -> BTree a -> BTree a
transform _ End = End
transform fx (Node val l r) =
  Node (fx val) (transform fx l) (transform fx r)

contents :: BTree a -> [a]
contents End = []
contents (Node v l r) =
  (contents l) ++ [v] ++ (contents r)

Feeder.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Feeder (updater) where

import           Control.Applicative
import           Data.Time
import           Network.Curl
import           Text.Feed.Import
import           Text.Feed.Types
import           Text.RSS.Syntax
import Control.Concurrent
import Control.Monad
import qualified BST as S
import Control.Concurrent.STM

updater :: (TVar S.AppState) -> IO ()
updater fx =
  (forkIO $ forever (refresher fx)) >> return ()
 where
   refresher f = do
     _ <- update f
     threadDelay 200000000
     return True
     
update :: (TVar S.AppState) -> IO ()
update f = (feeds f) >>= handle_feed f

feeds :: (TVar S.AppState) -> IO [S.Feed]
feeds f = atomically $ do
  (S.AppState fx _ _) <- readTVar f
  return $ S.contents fx

handle_feed :: TVar S.AppState -> [S.Feed] -> IO ()
handle_feed _ [] = return ()
handle_feed f (x:xs) = do
  (_,p) <- curlGetString (S.furl x) []
  case parseFeedString p of
    Just (RSSFeed fs) ->
      handle_items f (rssItems $ rssChannel fs)
    _ -> return ()
  handle_feed f xs

handle_items :: TVar S.AppState -> [RSSItem] -> IO ()
handle_items _ [] = return ()
handle_items f (x:xs) =
  case ((,,) <$> rssItemDescription x
        <*> rssItemTitle x
        <*> rssItemLink x) of
    Nothing -> return ()
    Just (d,t,l) -> do
      now <- getCurrentTime
      _ <- atomically $ do
        (S.AppState fd c a) <- readTVar f
        let xx = S.Content now d l t False "#F2F2F2"
        writeTVar f $ S.AppState fd (S.insert xx c) a
      handle_items f xs

Aww, damn. Feeder line 57 does not DWIM.