mahoro-0.1.1: DB.hs

{-# LANGUAGE DeriveDataTypeable #-}

-- | DB.hs
-- A module for work with database.

module DB (
    URL(..),
    JID(..),
    DB,
    DBProcess,
    newDB,
    addThread,
    delThread,
    delThreadAll,
    bye,
    getDescription,
    setDescription,
    getList,
    getUserThreads,
    getThread,    
    updateThread,
    dumpDB
) where

import Data.Typeable

import qualified Data.Map as M
import qualified Data.Set as S
import Data.List


-- Type structures.

-- | Map of threads, last post numbers and jids subscribed on them.
type Threads = M.Map URL (Integer, S.Set JID)
-- | Map of users threads descriptions.
type Users = M.Map JID (M.Map URL String)

-- | Because jids and urls presented as strings they wrapped in data
-- type to avoid confuse.
data JID = JID String deriving (Eq, Ord, Typeable)
data URL = URL String deriving (Eq, Ord, Typeable)

instance Show JID where
    show (JID jid) = jid
instance Show URL where
    show (URL url) = url

type DB = (Threads, Users)
type DBProcess = DB -> (String, DB)


-- | New db.
newDB :: DB
newDB = (M.empty, M.empty)


-- | Add new thread.
addThread :: URL -> JID -> DBProcess
addThread url jid db@(threads, users) =
    -- lookup if thread exist
    case M.lookup url threads of
      -- thread exist, lookup if user subscribed
      Just (_, jids) ->
        if S.member jid jids
          then ("You've already subscribed on this thread.", db)
          -- update threads and add to user
          else ("Done", (M.update addJID url threads, updateUsers))
      -- no such thread, add him to threads and add to user
      _ -> ("Done.", (M.insert url (0, S.singleton jid) threads, updateUsers))
  where
    addJID (n, jids) = Just (n, S.insert jid jids)

    updateUsers = M.update addDescr jid users'
    addDescr = Just . M.insert url ""
    -- if no user then create him
    users' = case M.lookup jid users of
               Just _ -> users
               _ -> M.insert jid M.empty users


-- | Del thread.
delThread :: URL -> JID -> DBProcess
delThread url jid db@(threads, users) =
    -- lookup if thread exist
    case M.lookup url threads of
      -- thread exist, lookup if user subscribed
      Just (_, jids) ->
        if S.member jid jids
          -- del from threads and del from users
          then ("Done", (M.update delJID url threads
                        ,delURL url jid users))
          -- not subscribed, do nothing
          else noSubscribe
      -- no such thread, do nothing
      _ -> noSubscribe
  where
    noSubscribe = ("You haven't subscribed on this thread.", db)
    
    delJID (n, jids) = if S.size jids == 1
                         then Nothing
                         else Just (n, S.delete jid jids)


delURL :: URL -> JID -> Users -> Users
delURL url jid users =
    M.update (Just . M.delete url) jid users


-- | Del thread for all users.
delThreadAll :: URL -> DBProcess
delThreadAll url db@(threads, users) =
    -- lookup if thread exist
    case M.lookup url threads of
      Just (_, jids) -> ("Done", (M.delete url threads
                                ,foldr (delURL url) users (S.toList jids)))
      _ -> ("No such thread.", db) 


-- | Delete all info about user from database.
bye :: JID -> DBProcess
bye jid db@(_, users) =
    -- get all urls on which user subscribed
    let urls = map fst $ getUserThreads jid db
    in ("Done",
        -- fst $ snd $ (String, (Threads, Users))
        (fst $ snd $ foldr (\u (_, db') -> delThread u jid db') ("", db) urls
        -- delete info about user
        ,M.delete jid users))


-- | Get user description on thread.
getDescription :: URL -> JID -> DB -> String
getDescription url jid (_, users) =
    case M.lookup jid users of
      Just descrs ->
        maybe "" id $ M.lookup url descrs
      _ -> ""


-- | Set user description on thread.
setDescription :: URL -> JID -> String -> DBProcess
setDescription url jid descr db@(threads, users) =
    case M.lookup jid users of
      Just descrs ->
        if M.member url descrs
          then ("Done", (threads, M.insert jid (newDescrs descrs) users))
          else noSubscribe
      _ -> noSubscribe
  where
    noSubscribe = ("You haven't subscribed on this thread.", db)

    newDescrs = M.update (const (Just descr)) url


-- | Get user subscribed threads.
getUserThreads :: JID -> DB -> [(URL, String)]
getUserThreads jid (_, users) = maybe [] M.toList $ M.lookup jid users


-- | Get list of all threads.
getList :: DB -> [URL]
getList (threads, _) = M.keys threads


-- | Get last post and jids of url.
getThread :: URL -> DB -> (Integer, [JID])
getThread url (threads, _) =
    case M.lookup url threads of
      Just (n, jids) -> (n, S.toList jids)
      _ -> (0, [])


-- | Update thread with new last post info.
updateThread :: URL -> Integer -> DBProcess
updateThread url lastPost (threads, users) =
    ("Done",
     (M.update (\(_, jids) -> Just (lastPost, jids)) url threads
     ,users))


-- | Dump db.
dumpDB :: DB -> String
dumpDB (threads, users) =
    "\n" ++
    showUs users
    ++ "\n\n" ++
    showTs threads


-- Helpers.

-- show users as "jid | thread | description"
showUs users =
    let us = map (\(j, ds) -> showDs j (M.toList ds))
                 (M.toList users)
        showDs j = intercalate "\n" . showD j
        showD j = map (\(u, d) -> show j ++ " | "++show u++" | "++d)
    in intercalate "\n" us

-- show threads as "url | jid1 jid2 jid3 | LastPostNumber"
showTs threads =
    let ts = map (\(u, (l, js)) -> showT u l (S.toList js))
                 (M.toList threads)
        showT u l js' = show u++" | "++showJs js'++" | "++show l
        showJs = intercalate " " . map show
    in intercalate "\n" ts