-----------------------------------------------------------------------------
-- |
-- 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 Language.Haskell.HsColour.CSS
import Text.XHtml.Strict
import Text.Printf
import Control.Concurrent       (forkIO)

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

--
-- SIGTERM support for shutting down cleanly
--
import System.Posix.Signals
import qualified System.Posix.Signals as Signal
import System.IO
import Control.Exception

------------------------------------------------------------------------
-- Signal handling

-- | Signals we want to handle
signals :: [Signal]
signals = [ softwareTermination ]

-- | Pretty printing of signals
sigmsg  :: Signal -> String
sigmsg s | s == softwareTermination = "SIGTERM"
         | otherwise                = "Killed by unknown signal"

-- | Intercept a signal. Now, if we could get back somehow get the shutdown hook out...
handleSignal :: Signal -> Signal.Handler
handleSignal s = CatchOnce $ do
    releaseSignals
    putStrLn ("Caught signal" ++ sigmsg s ++ ". Type 'e' to shutdown ...")

-- | Release all signal handlers
releaseSignals :: IO ()
releaseSignals = mapM_ (\s -> installHandler s Default Nothing) signals

installSignals :: IO ()
installSignals = mapM_ (\s -> installHandler s (handleSignal s) Nothing) signals

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

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

main = mainWith (forkIO . runBot)
  where
    mainWith f = bracket_ (installSignals) (releaseSignals) $ do
        hSetBuffering stdin NoBuffering
        ch <- newChan
        f ch
        accounts <- loadAccounts
        stdHTTP [hOut "/static/"               GET    wrapMaxAge
                ,hs "/static/"                 GET  $ basicFileServe "static/"
                ,h "/new$"                     GET  $ ok html handleGetNew
                ,h "/new$"                     POST $ handlePostNew ch
                ,h "/annotate/([0-9]+)"        GET    handleGetAnnotate
                ,h "/annotate/([0-9]+)$"       POST $ handlePostAnnotate ch
                ,h "/([0-9]+)/diff?"           GET    handleGetDiff
                ,h "/([0-9]+)/([0-9]+)/plain$" GET  $ ok plain handlePlain
                ,hOut "/([0-9]+)"              GET    noCacheWrapper
                ,h "/([0-9]+)"                 GET    handleGetDisplay
                ,adminSubsystem accounts
		,h "/googlebb3d1c6b96234414.html" () $ ok plain (val "")
                ,hOut "/(\\?.*)?$" GET                           noCacheWrapper
                ,h "/(\\?.*)?$" GET                              handleDefault
                ]

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

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

baseurl     :: String
-- baseurl     = "http://localhost:8000/"
baseurl     = "http://hpaste.org/"

srcurl      :: String
srcurl      = "http://www.scannedinavian.com/~eric/hpaste/"

ircurl      :: String
ircurl      = "http://haskell.org/haskellwiki/IRC_channel"

happsurl    :: String
happsurl    = "http://happs.org"

stylesheet  :: String
-- stylesheet  = "http://www.cse.unsw.edu.au/~dons/hpaste.css"
stylesheet  = "/static/hpaste.css"

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

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 html (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 html (val $ annotatePastePage pasteId nick startingText) () ()

handleGetAnnotate _ rq = request rq

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

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
handlePostAnnotate _  _      rq = request rq

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

handleGetDisplay :: Monad m => [String] -> Request -> PasteM m
handleGetDisplay [xs,_] rq = do
    case readM xs of
      Nothing      -> notFound html (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 html (val$ displayPastePage entryId entries now number) () ()
          else notFound html (val "404 not found") () ()

handleGetDisplay _ rq = request rq

handlePlain :: [String] -> Request -> Paste
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

handlePlain _ rq = request rq

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

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 html (val (listEntriesPage entries now offset moreEntries)) () ()

handleGetDiff :: Monad m => [String] -> Request -> PasteM m
handleGetDiff [xs,_] rq =
    case getInput of
      Nothing -> notFound html (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 html (val $ diffPage pasteId old new) () ()
  where
    getInput = liftM3 (,,) (readM xs) (readM $ lookS 6 rq "old")
                                      (readM $ lookS 6 rq "new")

handleGetDiff _ rq = request rq

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

-- | 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 =
    if nick /= titl
      then do
        now <- getTime
        act $ newEntry nick titl bdy now
        (m, url) <- msg nick titl pasteId
        when (lookS 8 rq "announce" == "true") $
          addSideEffect 10 $ writeChan ch m
    
        resp <- seeOther plain (val (url,"")) () ()
        return $ if isRememberSet rq
                  then liftM (setLastNickCookie nick =<<) resp
                  else liftM (clearLastNickCookie =<<) resp
      else
        seeOther plain (val ("/","")) () ()
  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"

    bdy = B.pack $ lookS 5000 rq "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, Monad m1) => () -> () -> m1 Result -> m (m1 Result)
noCacheWrapper () () = return . liftM (setHeader "Cache-Control" "no-cache")

------------------------------------------------------------------------
--
-- Markup
--

-- | Create a standard header
mkheader :: String -> Html
mkheader titl = header
         << (thetitle << (titl ++ " - hpaste") +++
             thelink ! [rel "stylesheet", thetype "text/css", href stylesheet]
             << noHtml +++
             script ! [thetype "text/javascript", src "/static/hi.js"]
             << noHtml +++
             meta ! [httpequiv "Content-Type"
                    ,content "text/html;charset=utf-8"])

newPastePage :: String -> String
newPastePage nick = naPastePage "/new" nick ""

annotatePastePage :: Int -> String -> String -> String
annotatePastePage entryId nick startingText
  = naPastePage ("/annotate/" ++ show entryId) nick startingText

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

--
-- new paste page
--
naPastePage :: String -> String -> String -> String
naPastePage target nick startingText = showHtml $
    mkheader "new" +++
    body << thediv ! [theclass "wrapper"]
    << (hpasteH1Header +++
        thediv ! [theclass "topnav"]
        << hotlink "/" << "recent" +++
        p ! [theclass "notice"]
	<< "Notice: hpaste is for small pastes and truncates after 5K. Pastes without a nick or a title are likely to be deleted!" +++
        gui target
        << (-- Text field:
            label ! [thefor "content"]
            << textarea ! [rows "24", cols "80"
                        ,identifier "content", name "content"]
               << startingText +++
            thediv
	    << (

           -- the nick form
            label ! [thefor "nick"]
            << ("author:" +++
                input ! [name "nick", identifier "nick"
                        ,thetype "text", value nick]
               ) +++

           -- whether to remember this
            label ! [thefor "remember"]
            << ("remember me:" +++
                input ! (if null nick then id else (checked :))
                        [thetype "checkbox", name "remember"
                        ,value "remember", identifier "remember"
                        ,theclass "checkbox"]
               ) +++

            -- paste title
            label ! [thefor "title"]
            << ("title:" +++
                textfield "title"
               ) +++

            -- whether to inform people on irc
            label ! [thefor "announce"]
            << ("announce:" +++
                input ! [thetype "checkbox", name "announce"
                        ,value "true", identifier "announce"
                        ,theclass "checkbox", checked]
               ) +++

            input ! [thetype "image", alt "save" ,theclass "submit"
                    ,src "/static/save.jpg"]
		    )
           )+++ p ! [theclass "footer"] << disclaimer
    )

--
-- All paste/statistics page
--
listEntriesPage :: [(Int, [Entry])] -> Int64 -> Int -> Bool -> String
listEntriesPage xs t' offset moreEntries = showHtml $
   mkheader "recent" +++
   body << thediv ! [theclass "wrapper"]
   << (listEntriesHeader +++
       table ! [theclass "pastes"]
        << (listEntriesTableHeader +++
            concatHtml
                [tr ! [strAttr "onclick" (printf "location.href='/%d'" entryId)
                      ,theclass "pastes"] << (
                 td << hotlink ("/" ++ show entryId) << "view" +++
                 td << entryNick x +++
                 td << formatShortTime t' (entryTime x) +++
                 td << entryTitle x +++
                 td << show (length xs'))

                | (entryId,(x:xs')) <- xs]
           ) +++

           thediv ! [theclass "pager"]
           << ((if offset > 0
                  then toHtml $ hotlink (printf "/?offset=%d" (offset-1))
                                << "newer"
                  else toHtml "newer")
               +++ " " +++
               (if moreEntries
                  then toHtml $ hotlink (printf "?offset=%d" (offset+1))
                                << "older"
                  else toHtml "older")
              ) +++
           p ! [theclass "footer"] << disclaimer
       )

hpasteH1Header :: Html
hpasteH1Header = h1 << hotlink "/" << (spaceHtml +++ thespan << "hpaste")

-- these two headers are constant and are used on every view
-- of the main list view page
listEntriesHeader :: Html
listEntriesHeader = hpasteH1Header +++
                    thediv ! [theclass "topnav"] << (hotlink "/" << "recent"
                                                     +++ " | " +++
                                                     hotlink "/new" << "new")

listEntriesTableHeader :: Html
listEntriesTableHeader = tr << (th << "link"   +++
                                th << "author" +++
                                th << "age"    +++
                                th << "title"  +++
                                th << "revisions")

-- disclaimer text
disclaimer :: Html
disclaimer =
    "Powered by "
        +++ hotlink happsurl << "HAppS"  +++ ". " +++
    "Copyright (c) 2007 glguy @ "
        +++ hotlink ircurl << "#haskell" +++ ". " +++
    "Source via "
        +++ hotlink srcurl << "darcs"    +++ "."

--
-- The 'view' page
-- note this uncompresses and unpacks the page
--
displayPastePage :: Int -> [Entry] -> Int64 -> Bool -> String
displayPastePage _ [] _ _ = showHtml $
    mkheader "paste deleted" +++
    body << thediv ! [theclass "wrapper"]
    << (hpasteH1Header +++
        p << "This paste has been deleted")
        
displayPastePage entryId xs t' number = showHtml $
    mkheader (entryTitle (head xs)) +++
    body << thediv ! [theclass "wrapper"]
    << (hpasteH1Header +++
        thediv ! [theclass "topnav"]
        << (hotlink "/" << "recent" +++
            " | " +++
            hotlink ("/annotate/" ++ show entryId)
            << "annotate" +++
            " | " +++
            hotlink "/new" << "new"
           ) +++

        [ hr +++
          thediv ! [theclass "pasteEntry", identifier ('a' : show n)]
          << (unordList [thespan ! [theclass "nickLabel"] << entryNick x
                        ,thespan ! [theclass "entryLabel"] << entryTitle x
                        ,thespan ! [theclass "entryTime"]
                         << formatTime t' (entryTime x)
                        ]
              ! [theclass "pasteHeader"] +++
              unordList [toHtml $ hotlink (printf "/%d/%d/plain" entryId n)
                                  << "raw"
                        ,toHtml (hotlink ("#a" ++ show n) << "link")
                               
                        ,toHtml $ hotlink (printf "/annotate/%d?oldId=%d"
                                                  entryId n) << "annotate"
                         ]
              ! [theclass "pasteLinks"]
             ) +++
            ( let s = entryContent x in formatContent (B.unpack s))
        | (n,x) <- zip [(0::Int)..] xs]
        +++
        thediv ! [theclass "pasteforms"]
        << (
        form ! [action ("/" ++ show entryId), method "get"]
        << fieldset ! [theclass "left"]
        << (label ! [thefor "lines"]
            << ("number lines:" +++
                input ! [thetype "checkbox", name "lines"
                        ,value "true", identifier "lines"
                        ,theclass "checkbox"]
                ! [flag | (True,flag) <- [(number,checked)]]
               ) +++
            button ! [thetype "submit"] << "format"
           ) +++
        diffForm +++
        thediv ! [theclass "clear"] << spaceHtml)
       )

    where
      diffForm
        | null (tail xs) = noHtml
        | otherwise = form ! [action (printf "/%d/diff" entryId)
                             ,method "get"]
                      << fieldset ! [theclass "right"]
                      << (label ! [thefor "old"]
                          << ("old: " +++ entrySelectbox "old") +++
                          label ! [thefor "new"]
                          << ("new: " +++ entrySelectbox "new") +++
                          button ! [thetype "submit"]  << "diff"
                         )

      entrySelectbox n
        = select ! [name n, identifier n]
          << [option ! [value (show n')]
             << longName n' e' | (n',e') <- zip [0..] xs]
        where
            longName :: Int -> Entry -> String
            longName line entry = printf "%d: %s" line (entryTitle entry)

      addLineNums
        = primHtml . ("<pre>"++) . unlines
        . zipWith (printf "%4d  %s") [(1::Int)..]
        . lines . drop 5

      formatContent x
        | number    = addLineNums colored
        | otherwise = primHtml colored
        where colored = hscolourFragment False x

--
-- The diff page
--
diffPage :: Int -> Entry -> Entry -> String
diffPage entryId xs ys = showHtml $
    mkheader "diff" +++
    body << thediv ! [theclass "wrapper"]
    << (hpasteH1Header +++
        thediv ! [theclass "topnav"]
        << (hotlink "/" << "recent" +++ " | " +++
            hotlink "/new" << "new" +++ " | " +++
            hotlink ("/" ++ show entryId) << "normal"
           ) +++
        hr +++
        thediv ! [theclass "pasteEntry"]
        << (unordList [toHtml $ thespan ! [theclass "fromLabel"] << "Old:"
                      ,toHtml $ ' ' : entryTitle xs
                      ,toHtml $ thespan ! [theclass "toLabel"] << "New:"
                      ,toHtml $ ' ' : entryTitle ys
                      ] ! [theclass "pasteHeader"] +++
            unordList [hotlink "#" << "link"] ! [theclass "pasteLinks"]
           ) +++
        pre
        << htmlDiff (entryToScrubbed xs) (entryToScrubbed ys)
       )
  where
    entryToScrubbed x =
        let s = entryContent x
        in B.pack . scrub . hscolourFragment False . B.unpack $ s
    scrub = lastN 6 . drop 5
    lastN n as = zipWith const as (drop n as)

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

formatShortTime :: Int64 -> Int64 -> String
formatShortTime to from
  | delta < 60    = shows delta "s"
  | delta < 3600  = shows (div delta 60) "m"
  | delta < 86400 = shows (div delta 3600) "h"
  | otherwise     = shows (div delta 86400) "d"
  where delta = to - from

formatTime :: Int64 -> Int64 -> String
formatTime to from
  | delta < 60    = shows delta " seconds ago"
  | delta < 120   = "1 minute ago"
  | delta < 3600  = shows (div delta 60) " minutes ago"
  | delta < 7200  = "1 hour ago"
  | delta < 86400 = shows (div delta 3600) " hours ago"
  | delta < 172800 = "1 day ago"
  | otherwise = shows (div delta 86400) " days ago"
  where delta = to - from