{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE TypeFamilies       #-}

import           Control.Applicative
import           Control.Concurrent
import           Control.Lens
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Acid
import qualified Data.Aeson            as J
import qualified Data.ByteString.Char8 as BS
import           Data.Function         (on)
import qualified Data.IntMap.Strict    as IM
import           Data.List
import qualified Data.Map.Strict       as M
import           Data.Maybe
import           Data.SafeCopy
import qualified Data.Text             as T
import           Data.Time.Clock
import           Data.Typeable
import qualified Data.Vector           as V
import qualified Network.Http.Client   as H
import           System.Environment    (getArgs)
import qualified Text.Feed.Import      as F
import qualified Text.Feed.Query       as F
import qualified Text.Feed.Types       as F
import qualified Web.Scotty            as W

----------------------------------------------------------------------------------------------------

type Url = String
type Tag = String
type Flag = String
type Id = Int

data Article = Article { _storyId     :: !String
                        , _title      :: !String
                        , _link       :: !Url
                        , _content    :: !String
                        , _pubDate    :: !String
                        , _readStatus :: !Bool
                        , _flags      :: ![Flag] } deriving Typeable

$(makeLenses ''Article)

data Articles = Articles !(M.Map Url Article) deriving Typeable

data Feed = Feed { _feedId       :: !Int
                    , _feedTitle :: !String
                    , _feedLink  :: !Url
                    , _tags      :: ![Tag]
                    , _stories   :: !Articles}

$(makeLenses ''Feed)

-- This is an IntMap and not a vector since we might want to delete, insert feeds at a later point,
-- while keeping original feed ids.
data Feeds = Feeds !(IM.IntMap Feed) deriving Typeable

$(deriveSafeCopy 0 'base ''Article)
$(deriveSafeCopy 0 'base ''Articles)
$(deriveSafeCopy 0 'base ''Feed)
$(deriveSafeCopy 0 'base ''Feeds)

instance J.ToJSON Articles where
    toJSON (Articles as) = J.object [("stories", J.Array $ V.fromList $ map J.toJSON $ M.elems as)]

instance J.ToJSON Article where
    toJSON a = J.object [ ("id", J.String $ T.pack $ a^.storyId)
                            , ("story_title", J.String $ T.pack $ a^.title)
                            , ("story_permalink", J.String $ T.pack $ a^.link)
                            , ("story_content", J.String $ T.pack $ a^.content)
                            , ("story_date", J.String $ T.pack $ a^.pubDate)
                            , ("read_status", J.Bool $ a^.readStatus)]

instance J.ToJSON Feeds where
    toJSON (Feeds fs) = J.object [("feeds", J.object xs)]
        where xs = map (\f -> (T.pack $ show (f^.feedId), J.object [("feed_title", J.String $ T.pack $ f^.feedTitle), ("feed_link", J.String $ T.pack $ f^.feedLink)])) (IM.elems fs)

markAllRead :: Id -> Update Feeds ()
markAllRead i = modify $ \(Feeds fs) -> Feeds $ IM.adjust (stories %~ \(Articles as) -> Articles (M.map (readStatus .~ True) as)) i fs

markArticleRead :: Id -> Url -> Bool -> Update Feeds ()
markArticleRead i url r = modify $ \(Feeds fs) -> Feeds $ IM.adjust (stories %~ \(Articles as) -> Articles (M.adjust (readStatus .~ r) url as)) i fs

updateArticleFlags :: Id -> Url -> [Flag] -> Update Feeds ()
updateArticleFlags i url fls = modify $ \(Feeds fs) -> Feeds $ IM.adjust (stories %~ \(Articles as) -> Articles (M.adjust (flags .~ fls) url as)) i fs

subscribedUrls :: Query Feeds [(Id, Url)]
subscribedUrls = ask >>= \(Feeds m) -> return $ map (\(i, f) -> (i, f^.feedLink)) (IM.toList m)

fetchFeed :: Id -> Query Feeds Articles
fetchFeed i = do
    Feeds m <- ask
    return $ (m IM.! i) ^. stories

ask_ :: Query Feeds Feeds
ask_ = ask


----------------------------------------------------------------------------------------------------

newKey :: IM.IntMap a -> Int
newKey fs | IM.null fs = 1
newKey fs = fst (IM.findMax fs) + 1

importUrls :: [(Url, [Tag])] -> Update Feeds ()
importUrls urls = do
    Feeds fs <- get

    let urls' = nubBy ((==) `on` fst) urls
        present = map (_feedLink . snd) $ IM.toList fs
        newFeed j url ts = Feed j url url ts (Articles M.empty)

    put $ Feeds $ foldr (\(url, ts) f -> if url `elem` present then f else IM.insert (newKey f) (newFeed (newKey f) url ts) f) fs urls'

getFeed :: Url -> IO (Maybe F.Feed)
getFeed url = do
    x <- H.get (BS.pack url) H.concatHandler
    return $ F.parseFeedString $ BS.unpack x

getFeeds :: Feeds -> IO Feeds
getFeeds (Feeds fs) = Feeds <$> IM.foldrWithKey (\i f m -> do
                xs <- m
                mf <- getFeed (f^.feedLink)
                return $ IM.update (const (fmap (parseFeed i (f^.tags)) mf)) i xs
                ) (return fs) fs

put_ :: Feeds -> Update Feeds ()
put_ = put


parseFeed :: Id -> [Tag] -> F.Feed -> Feed
parseFeed i ts f = Feed i (F.getFeedTitle f) (fromMaybe "No feed url" $ F.getFeedHome f) ts (parseArticles (F.getFeedItems f))

parseArticles :: [F.Item] -> Articles
parseArticles = Articles . M.fromList . mapMaybe h
    where
    h item = F.getItemLink item >>=
             \aLink -> Just (aLink, Article aLink
                                            (fromMaybe "No title" (F.getItemTitle item))
                                            aLink
                                            (fromMaybe "No description" (F.getItemDescription item))
                                            (case F.getItemPublishDate item of
                                                Nothing -> "No publisher date"
                                                Just t -> case t of
                                                    Nothing -> fromMaybe "No publisher date" $ F.getItemPublishDateString item
                                                    Just t1 -> show (t1 :: UTCTime))
                                             False
                                             [])


$(makeAcidic ''Feeds ['markAllRead
                        , 'markArticleRead
                        , 'updateArticleFlags
                        , 'subscribedUrls
                        , 'fetchFeed
                        , 'importUrls
                        , 'put_
                        , 'ask_])
----------------------------------------------------------------------------------------------------

every :: Int -> IO a -> IO ThreadId
every m action = forkIO $ forever $ action >> threadDelay (m * 60 * 1000000)

parseFeedId :: String -> Id
parseFeedId = read

parseStoryId :: String -> Url
parseStoryId = id

----------------------------------------------------------------------------------------------------

main :: IO ()
main = do
    args <- getArgs
    acidFeeds <- openLocalState $ Feeds IM.empty

    unless (null args) $ do
            urls <- map (\l -> (head $ words l, tail $ words l)) <$> lines <$> readFile (head args)
            update acidFeeds (ImportUrls urls)

    xs <- query acidFeeds SubscribedUrls
    fs <- query acidFeeds Ask_

    let ids = map fst xs

    _ <- every 5 $ do
        fs' <- getFeeds fs
        update acidFeeds (Put_ fs')

    W.scotty 3000 $ do
        W.post "/api/login" $
            -- dummy authentication
            W.json $ J.object [("authenticated", J.Bool True)]

        W.post "/api/logout" $
            -- dummy authentication
            W.json $ J.object [("authenticated", J.Bool False)]

        W.get "/reader/feeds" $ do
            feeds <- lift $ query acidFeeds Ask_
            W.json feeds

        W.post "/reader/mark_feed_as_read" $ do
            i <- W.param "feed_id"
            let url = parseFeedId i
            _ <- lift $ update acidFeeds (MarkAllRead url)
            W.html ""

        let
            updateReadFlag b = do
                i <- W.param "feed_id"
                sid <- W.param "story_id"
                let url = parseFeedId i
                    sid' = parseStoryId sid
                _ <- lift $ update acidFeeds (MarkArticleRead url sid' b)
                W.html ""

        W.post "/reader/mark_story_as_read" $ updateReadFlag False

        W.post "/reader/mark_story_as_unread" $ updateReadFlag True

        mapM_ (\i ->
                W.get (W.capture ("/reader/feed/" ++ show i)) $ do
                    as <- lift $ query acidFeeds (FetchFeed i)
                    W.json as) ids

    closeAcidState acidFeeds
