-----------------------------------------------------------------------------
-- |
-- Module      : HPaste
-- Copyright   : (c) Eric Mertens 2007
-- License     : BSD3-style (see LICENSE)
-- 
-- Maintainer  : emertens@gmail.com
-- Stability   : unstable
-- Portability : portable, Haskell 98.
--
-----------------------------------------------------------------------------
--
-- The HPaste server
--

import Data.Char
import Data.Int
import qualified Data.ByteString.Char8 as B
import Data.Maybe
import Data.List
import Control.Concurrent.Chan
import Control.Monad
import Control.Concurrent       (forkIO)

import HAppS
import PasteState
import HPasteAdmin
import PasteBot
import DiffHtml (htmlDiff)

import HtmlPages

import System.IO
import Control.Exception

------------------------------------------------------------------------
-- Start the bot up

main :: IO ()
-- main = mainWith (const (return ()))

main = mainWith (forkIO . runBot)
  where
    mainWith f = do
        ch <- newChan
        f ch
        accounts <- loadAccounts
        stdHTTP [debugFilter
                ,hOut (Prefix ["static"])       GET    wrapMaxAge
                ,h (Prefix ["static"])         GET  $ (\path rq -> respond $ fileServe "static/" path rq)
                ,h ["new"]                      GET  $ ok handleGetNew
                ,h ["new"]                      POST $ handlePostNew ch
                ,h (re ["annotate","([0-9]+)"]) GET    handleGetAnnotate
                ,h (re ["annotate","([0-9]+)"]) POST $ handlePostAnnotate ch
                ,h (re ["([0-9]+)","diff"])     GET    handleGetDiff
                ,h (re ["([0-9]+)","([0-9]+)","plain"]) GET  $ ok handlePlain
                ,hOut (re ["([0-9]+)"])         GET    noCacheWrapper
                ,h (re ["([0-9]+)"])            GET    handleGetDisplay
                ,adminSubsystem accounts
                ,hOut [""] GET                         noCacheWrapper
                ,h    [""] GET                         handleDefault
                ]

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

wrapMaxAge :: Monad m => () -> () -> PEv (Result -> m Result)
wrapMaxAge () () = return (return . setHeader "Cache-Control" "max-age=86400")

baseurl     :: String
baseurl     = "http://hpaste.org/"

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

handleGetNew :: () -> Request -> Paste
handleGetNew () rq = respond . newPastePage . lastNick $ rq

handlePostNew :: Monad m => Chan PasteAnnounce -> () -> Request -> PasteM m
handlePostNew ch () rq = do
    entryId <- currentId
    buildEntry ch rq entryId storeEntry buildNewPasteMessage

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

handleGetAnnotate :: Monad m => [String] -> Request -> PasteM m
handleGetAnnotate [xs] rq = do
  case readM xs of
    Nothing      -> notFound (val "404 paste not found") () ()
    Just pasteId -> do
      startingText <- case readM (lookS 5 rq "oldId") of
                        Nothing    -> return ""
                        Just oldId -> do
                          entries <- getEntries pasteId
                          return $
                           if length entries > oldId
                            then B.unpack . entryContent $ entries !! oldId
                            else ""
      let nick = lastNick rq
      ok (val $ annotatePastePage pasteId nick startingText) () ()

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

handlePostAnnotate :: Monad m => Chan PasteAnnounce -> [String] -> Request -> PasteM m
handlePostAnnotate ch [xs] rq = do
    let entryId = read xs
    buildEntry ch rq entryId (storeAnnotation entryId) buildAnnotationMessage

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

handleGetDisplay :: Monad m => [String] -> Request -> PasteM m
handleGetDisplay [xs] rq = do
    case readM xs of
      Nothing      -> notFound (val "404 not found") () ()
      Just entryId -> do
        maxId <- currentId
        if entryId < maxId
          then do
            entries <- getEntries entryId
            now <- getTime
            let number = lookS 4 rq "lines" == "true"
            ok (val $ displayPastePage entryId entries now number) () ()
          else notFound (val "404 not found") () ()

handlePlain :: [String] -> Request -> PEv (Either Request String)
handlePlain [xs,ys] rq = do
    entries <- getEntries entryId
    if null entries || aid >= length entries
      then request rq
      else let s = entryContent $ entries !! aid
           in respond (B.unpack s)
    where entryId = read xs
          aid = read ys

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

handleDefault :: Monad m => () -> Request -> PasteM m
handleDefault () rq = do
    let offset = fromMaybe 0 $ readM $ lookS 6 rq "offset"
    (entries,rest) <- liftM (splitAt 25 . drop (25 * offset)) allEntries
    let moreEntries = not . null $ rest
    now <- getTime
    ok (val (listEntriesPage entries now offset moreEntries)) () ()

handleGetDiff :: Monad m => [String] -> Request -> PasteM m
handleGetDiff [xs] rq =
    case getInput of
      Nothing -> notFound (val "paste not found") () ()
      Just (pasteId, oldId, newId) -> do
        entries <- getEntries pasteId
        let numEntries = length entries
            old = entries !! oldId
            new = entries !! newId
        if newId >= numEntries || oldId >= numEntries
          then request rq
          else ok (val $ diffPage pasteId old new) () ()
  where
    getInput = liftM3 (,,) (readM xs) (readM $ lookS 6 rq "old")
                                      (readM $ lookS 6 rq "new")

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

--

-- | build a new entry
--
buildEntry ::
  Monad m =>
  Chan PasteAnnounce
  -> Request
  -> Int
  -> (Entry -> PEv ())
  -> (String -> String -> Int -> PEv (PasteAnnounce, String))
  -> PasteM m
buildEntry ch rq pasteId act msg = do
    now <- getTime
    let ent = newEntry nick titl bdy now
    if spammy
        then do seeOther (val ("/","")) () ()
        else do      
            act ent
            (m, url) <- msg nick titl pasteId
            when (lookS 8 rq "announce" == "true") $
                addSideEffect 10 $ writeChan ch m
            seeOther (val (url,"")) () ()
  where
    nick | null n    = "(anonymous)"
         | otherwise = n
         where n = lookS 15  rq "nick"

    titl | null t'   = "(no title)"
         | otherwise = t'
         where t' = lookS 100 rq "title"

    content = lookS 5000 rq "content"

    bdy = B.pack content

    spammy = (nick == titl)  -- sufficient for now
          || "a href" `isInfixOf` content

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

isRememberSet :: Request -> Bool
isRememberSet rq = lookS 8 rq "remember" == "remember"

lastNick :: Request -> String
lastNick rq = maybe "" cookieValue (getCookie "lastNick" rq)

setLastNickCookie :: Monad m => String -> Result -> m Result
setLastNickCookie nick
  = setCookieEx maxBound $ Cookie "1" "/" "" "lastNick" nick

clearLastNickCookie :: Monad m => Result -> m Result
clearLastNickCookie = setCookieEx 0 (Cookie "1" "/" "" "lastNick" "")

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

buildNewPasteMessage :: Monad m => String -> String
                     -> Int -> m (PasteAnnounce, String)

buildNewPasteMessage nick titl entryId = return (NewPaste nick titl url, url)
    where url = baseurl ++ show entryId

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

buildAnnotationMessage :: String -> String -> Int -> PEv (PasteAnnounce, String)
buildAnnotationMessage nick titl entryId = do
    originals <- getEntries entryId
    let annoId = length originals - 1
        url = baseurl ++ show entryId ++ "#a" ++ show annoId
    return (Annotation nick (entryTitle $ originals !! 0) titl url, url)

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

-- Used to add a no-cache header to a response
noCacheWrapper :: Monad m => () -> () -> PEv (Result -> m Result)
noCacheWrapper () () = return (return . setHeader "Cache-Control" "no-cache")