-- | Controllers.hs
-- A module which contain controllers for requests to happstack.

module Controllers (
    controllers
) where

import Config
import Board
import BoardUtils
import BoardState
import DisplayHTML

import Happstack.Server
import Happstack.State
import Happstack.Server.HSP.HTML
import Happstack.Helpers

import Data.List
import Data.List.Split
import Data.Monoid
import Control.Monad
import Control.Monad.State
import Control.Monad.Reader

controllers :: Config -> ServerPartT IO Response
controllers cf = msum
    -- if root dir then redirect to `*' tag
    [ exactdir "/" (seeOther "/*/" (toResponse "")) 
    -- bot
    , dir (cprivateKey cf) handleBot
    -- show post
    , path handlePost
    -- static files
    , dir "_static" (fileServe [] "_static")
    -- board tag
    , path handleTag
    -- if no any matches
    , anyPath (webHSP wrongPath)
    ]

handlePost :: Int -> ServerPart Response
handlePost postNum = do
    rq <- askRq
    if null $ rqPaths rq
      then do
        board <- query GetBoard'
        case getFullPath postNum board of
          Just (tNum, pNum) ->
            -- if not thread then redirect to thread
            if pNum /= 0
              then seeOther ("/"++show tNum++"#"++show pNum)
                            (toResponse "")
              -- 404 or our thread
              else webHSP $
                     maybe noPost
                           displayOneThread
                             (getOneThread tNum board)
          -- 404
          _ -> webHSP noPost
      else webHSP wrongPath

handleTag :: String -> ServerPart Response
handleTag tagsStr = do
    rq <- askRq
    -- redirect to zero page.
    if null $ rqPaths rq
      then seeOther ("/"++tagsStr++"/0") (toResponse "")
      else msum [ path (handleTagPage tagsStr)
                , webHSP $ wrongPath
                ]

handleTagPage :: String -> Int -> ServerPart Response
handleTagPage tagsStr page = do
    rq <- askRq
    if null $ rqPaths rq
      then do
        board <- query GetBoard'
        -- parse tags
        let f = parseTags tagsStr
        webHSP $
          -- display page this threads or 404
          maybe
            (displayError "No such page.")
            (\(pages, tagsPosts) ->
                displayBoard tagsStr (page, pages) tagsPosts)
              (getBoard f page board)
      else webHSP wrongPath

wrongPath = displayError "Wrong path!"
noPost = displayError "No such post."

parseTags tagsStr =
    if tagsStr == "*"
      then Nothing
      else
        if '*' `elem` tagsStr
          then Just (`elem` (splitOn "*" tagsStr))
          else if "-" `isPrefixOf` tagsStr
                 then Just (not . (`elem` (splitOn "-" (tail tagsStr))))
                 else Just (==tagsStr)

---
--- Bot API.
---

handleBot :: ServerPartT IO Response
handleBot = msum
    [ dir "newpost" (methodSP POST handleNewPost)
    , dir "newthread" (methodSP POST handleNewThread)
    , dir "delpost" (methodSP POST handleDelPost)
    ]

handleNewPost :: ServerPartT IO Response
handleNewPost = do
    NewPost sage replyto url body <- getData'
    post <- liftIO $ createPost replyto url body
    (update $ NewPost' sage post) >>=
      respOkOrFail (ppassword post)

handleNewThread :: ServerPartT IO Response
handleNewThread = do
    NewThread tag url body <- getData'
    post <- liftIO $ createPost 0 url body
    (update $ NewThread' tag post) >>=
      respOkOrFail (ppassword post)

handleDelPost :: ServerPartT IO Response
handleDelPost = do
    DelPost number password <- getData'
    (update $ DelPost' number password) >>=
      respOkOrFail ""

-- Helpers.
respOkOrFail :: String -> Result -> ServerPartT IO Response
respOkOrFail p r = return $ toResponse $ okOrFail p r

okOrFail _ (Left err) = "FAIL "++err
okOrFail _ (Right 0) = "OK"
okOrFail pass (Right number) = "OK "++show number++" "++pass

-- Parse instances.

data NewPost = NewPost Bool Int (Maybe String) String
instance FromData NewPost where
    fromData = liftM4 NewPost
                      (return . not . null =<< look "sage" `mplus` (return ""))
                      (lookInt "replyto")
                      lookImg
                      (lookStr "body")

data NewThread = NewThread String (Maybe String) String
instance FromData NewThread where
    fromData = liftM3 NewThread
                      (lookStr "tag")
                      lookImg
                      (lookStr "body")

data DelPost = DelPost Int String
instance FromData DelPost where
    fromData = liftM2 DelPost
                      (lookInt "number")
                      (lookStr "password")

-- Helpers.
lookStr s = look s `mplus` (return "")
lookInt s = return . read =<< look s `mplus` (return "0")
lookImg = liftM strToMaybe (look "imgurl" `mplus` (return ""))
strToMaybe str = if null str then Nothing else Just str