primula-board-0.0.1: Board.hs

{-# LANGUAGE DeriveDataTypeable #-}

-- | Board.hs
-- A module which contain board's structures and functions to operate
-- with them.

module Board (
    Board,
    Posts,
    TagPosts,
    Threads,
    SeqThreads,
    Post(..),
    Thread(..),
    BoardProcess,
    BoardResult,
    newBoard,
    newPost,
    newThread,
    delPost,
    getOneThread,
    getBoard,
    getFullPath
) where

import Data.Typeable
import Happstack.State.ClockTime

import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import Data.Sequence ((<|))
import qualified Data.Foldable as Foldable

import Data.Maybe
import Data.List.Split


-- Type structures.


type Board = (Posts, Threads, SeqThreads)
type Posts = Map.Map Int Post
type TagPosts = (String, Int, [Post])
type Threads = Map.Map Int Thread
type SeqThreads = Seq.Seq Int

data Post = Post
    { pnumber :: Int
    , preplyto :: Int
    , pimgurl :: Maybe String
    , pbody :: String
    , pthread :: Int
    , pdatetime :: ClockTime
    , ppassword :: String
    } deriving (Show, Typeable)

data Thread = Thread
    { ttag :: String
    , tposts :: [Int]
    } deriving (Show, Typeable)

type BoardProcess = Board -> BoardResult
type BoardResult = Either String (Int, Board)


-- Module-specified functions. Should be executed ONLY as transactions.


newBoard :: Board
newBoard = (Map.empty, Map.empty, Seq.empty)

newPost :: Bool -> Post -> BoardProcess
newPost sage post (posts, threads, seq) =
    -- find replyto post
    case Map.lookup (preplyto post) posts of
      Just p ->
        let -- insert our new post in posts
            post' = post{pnumber = newNumber, pthread = tNum}
            posts' = Map.insert newNumber post' posts
            -- update posts in that thread
            (_, threads') = Map.updateLookupWithKey updTPosts tNum threads
            -- if not sage then bump thread
            seq' = if sage then seq
                           else bump
        in Right (newNumber, (posts', threads', seq'))
        where
            tNum = pthread p
            newNumber = incNumber posts
            -- add number of new post in thread
            updTPosts _ t = Just $ t{tposts = (tposts t)++[newNumber]}
            -- bump: delete old position and add to begin
            bump = tNum <| (filterSeq (/=tNum) seq)
      _ ->
        Left "No replyto post."

newThread :: String -> Post -> BoardProcess
newThread tag post (posts, threads, seq) = 
    -- just create new post and new thread
    let newNumber = incNumber posts
        post' = post{pnumber = newNumber, pthread = newNumber} 
        posts' = Map.insert newNumber post' posts
        thread = Thread{ttag = tag, tposts = [newNumber]}
        threads' = Map.insert newNumber thread threads
        seq' = newNumber <| seq
    in Right (newNumber, (posts', threads', seq'))

delPost :: Int -> String -> BoardProcess
delPost number password (posts, threads, seq) =
    -- check if our post exist
    case Map.lookup number posts of
      Just p | password == (ppassword p) ->
        -- if it thread then delete him and posts
        -- else delete post and update thread posts
        let board' =
              if (preplyto p) == 0
                then (Map.filterWithKey filtTPosts posts
                     ,Map.delete number threads
                     ,filterSeq (/=number) seq)
                else (Map.delete number posts
                     ,snd $ Map.updateLookupWithKey updTPosts tNum threads
                     ,seq)
        in Right (0, board')
        where
            tNum = pthread p
            filtTPosts k _ = not $ k `elem` ttposts
            updTPosts _ t = Just $ t{tposts = filter (/=number) (tposts t)}
            -- posts of our thread
            ttposts = case Map.lookup number threads of
                        Just t -> tposts t
                        _ -> []
      Nothing ->
        Left "No such post."
      _ ->
        Left "Password is incorrect."


-- Data access functions.


-- | Get posts from specified thread.
getOneThread :: Int -> Board -> Maybe TagPosts
getOneThread = getThreadPosts True

getThreadPosts :: Bool -> Int -> Board -> Maybe TagPosts
getThreadPosts full tNum (posts, threads, _) =
    case Map.lookup tNum threads of
      Just thread ->
        let (lPosts, omitted) =
              if full
                then (ttposts, 0)
                else getPartial 6 ttposts
            ttposts = tposts thread
        in Just $ (ttag thread
                  ,omitted
                  ,catMaybes $ map (flip Map.lookup posts) lPosts)
      _ -> Nothing

-- | Filter all board threads with external function.  Return all
-- pages number and tagsPosts (partial threads) from specified page.
getBoard :: Maybe (String -> Bool) -> Int -> Board -> Maybe (Int, [TagPosts])
getBoard maybeF page board@(_, threads, seq) =
    let threads' =
          case maybeF of
            Just f -> Map.filter (\t -> f (ttag t)) threads
            _ -> threads
        -- get filtered thread numbers
        tNums = Map.keys threads'
        -- get right sequence of filtered threads
        tNums' = filter (`elem` tNums) $ Foldable.toList seq
        -- split on pages
        pages = chunk 10 tNums'
        (posts, pagesN) = if len == 0 then ([], 0) else (pages!!page, len-1)
        len = length pages
    in if page `elem` [0..pagesN]
         then Just 
              (pagesN
              ,catMaybes $
                 map (flip (getThreadPosts False) board) posts)
         else Nothing

-- | Find post full path (threadNum, postNum)
getFullPath :: Int -> Board -> Maybe (Int, Int)
getFullPath postNum (posts, _, _) =
    case Map.lookup postNum posts of
      Just post ->
        Just $ if (preplyto post) == 0
                 then (postNum, 0)
                 else (pthread post, postNum)
      _ -> Nothing


-- Helper functions.


-- | Find new post number.
incNumber :: Posts -> Int
incNumber posts =
    if Map.null posts
      then 1
      else fst (Map.findMax posts) + 1

-- | Filter function for Seq monad.
filterSeq :: (a -> Bool) -> Seq.Seq a -> Seq.Seq a
filterSeq f m = (\x -> if f x then return x else Seq.empty) =<< m

-- | Get partial list from another list.
getPartial :: Int -> [a] -> ([a], Int)
getPartial maxL xs | maxL < 2 = (xs, 0)
getPartial maxL xs =
    case length xs of
      n | n `elem` [0..maxL] -> (xs, 0)
      n' -> let ps = (head xs):
                    (reverse $ take (maxL - 1) $ reverse xs)
           in (ps, n' - maxL)