----------------------------------------------------------------------------- -- | -- 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.State import Language.Haskell.HsColour.CSS import Text.XHtml.Strict import Text.Printf import Control.Concurrent (forkIO) import HAppS import PasteState 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 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 $ ok html handleGetAnnotate ,h "/annotate/([0-9]+)$" POST $ handlePostAnnotate ch ,h "/([0-9]+)/diff?" GET $ ok html handleGetDiff ,h "/([0-9]+)/([0-9]+)/plain$" GET $ ok plain handlePlain ,h "/([0-9]+)" GET $ ok html handleGetDisplay ,h () () handleDefault ] html :: String -> P Result html = ctype "text/html; charset=utf-8" id ------------------------------------------------------------------------ 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" ------------------------------------------------------------------------ -- -- some useful synonyms for this hairy stuff -- type P a = Ev PasteState Request a type Paste = P (Either Request String) type PasteM m = P (Either Request (m Result)) ------------------------------------------------------------------------ handleGetNew :: () -> Request -> Paste handleGetNew () = respond . newPastePage . lastNick handlePostNew :: Monad m => Chan PasteAnnounce -> () -> Request -> PasteM m handlePostNew ch () rq = do entryId <- gets currentId buildEntry ch rq entryId storeEntry buildNewPasteMessage ------------------------------------------------------------------------ handleGetAnnotate :: [String] -> Request -> Paste handleGetAnnotate [xs,_] rq = do let entryId = read xs nick = lastNick rq fromId = lookS 5 rq "oldId" startingText <- if null fromId then return "" else do entries <- gets (getEntries entryId) let s = entryContent (entries !! read fromId) return (B.unpack s) respond $ annotatePastePage entryId 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 :: [String] -> Request -> Paste handleGetDisplay [xs,_] rq = do entries <- gets (getEntries entryId) now <- getTime let number = lookS 4 rq "lines" == "true" if null entries then request rq else respond $ displayPastePage entryId entries now number where entryId = read xs handleGetDisplay _ rq = request rq handlePlain :: [String] -> Request -> Paste handlePlain [xs,ys,_] rq = do entries <- gets (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 = readDefault 0 $ lookS 6 rq "offset" (entries,rest) <- liftM (splitAt 25 . drop (25 * offset)) $ gets allEntries let moreEntries = not . null $ rest now <- getTime (liftM . liftM . liftM $ setHeader "Cache-Control" "no-cache") $ ok html (val (listEntriesPage entries now offset moreEntries)) () () handleGetDiff :: [String] -> Request -> Paste handleGetDiff [xs,_] rq = do entries <- gets (getEntries entryId) let numEntries = length entries fromEntry = entries !! fromId toEntry = entries !! toId if numEntries == 0 || fromId >= numEntries || toId >= numEntries then request rq else respond $ diffPage entryId fromEntry toEntry where entryId = read xs fromId = read $ lookS 6 rq "old" toId = read $ lookS 6 rq "new" handleGetDiff _ rq = request rq ------------------------------------------------------------------------ -- | build a new entry buildEntry :: (ToSURI t1, Monad m) => Chan PasteAnnounce -> Request -> t -> (Entry -> PasteState -> PasteState) -> ([Char] -> [Char] -> t -> Ev PasteState Request (PasteAnnounce, t1)) -> PasteM m buildEntry ch rq entryId act msg = do now <- getTime modify $ act $ newEntry nick titl bdy now (m, url) <- msg nick titl entryId when (lookS 6 rq "silent" /= "silent") $ addSideEffect 10 $ writeChan ch m resp <- seeOther plain (val (url,"")) () () return $ if lookS 8 rq "remember" == "remember" then liftM (setLastNickCookie nick =<<) resp else resp 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" ------------------------------------------------------------------------ lastNick :: Request -> [Char] lastNick rq = maybe "" cookieValue (getCookie "lastNick" rq) setLastNickCookie :: (Monad m) => String -> Result -> m Result setLastNickCookie nick = setCookieEx maxBound (Cookie "1" "/" "" "lastNick" nick) ------------------------------------------------------------------------ buildNewPasteMessage :: (Monad m) => String -> String -> Int -> m (PasteAnnounce, [Char]) buildNewPasteMessage nick titl entryId = return (NewPaste nick titl url, url) where url = baseurl ++ show entryId ------------------------------------------------------------------------ buildAnnotationMessage :: String -> String -> Int -> P (PasteAnnounce, [Char]) buildAnnotationMessage nick titl entryId = do originals <- gets (getEntries entryId) let annoId = length originals - 1 url = baseurl ++ show entryId ++ "#" ++ show annoId return (Annotation nick (entryTitle $ originals !! 0) titl url, url) ------------------------------------------------------------------------ -- -- Markup -- -- | Create a standard header mkheader :: [Char] -> Html mkheader titl = header << (thetitle << (titl ++ " - hpaste") +++ thelink ! [rel "stylesheet", thetype "text/css", href stylesheet] << noHtml) 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"] << (h1 << thespan << "hpaste" +++ thediv ! [theclass "topnav"] << hotlink "/" << "recent" +++ gui target << fieldset << ( -- Text field: label ! [thefor "content"] << ( textarea ! [rows "24", cols "80" ,identifier "content", name "content"] << startingText) +++ -- 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 ! [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 "silent"] << ("silent:" +++ input ! [thetype "checkbox", name "silent" ,value "silent", identifier "silent" ,theclass "checkbox"] ) +++ 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 $ listHeader +++ (table ! [theclass "pastes"] << (foldl' (+++) (tr << ( th << "link" +++ th << "author" +++ th << "age" +++ th << "title" +++ th << "revisions")) [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 ) -- all list page header listHeader :: Html listHeader = mkheader "recent" +++ body << thediv ! [theclass "wrapper"] << (h1 << thespan << "hpaste" +++ thediv ! [theclass "topnav"] << (hotlink "/" << "recent" +++ " | " +++ hotlink "/new" << "new")) -- 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 entryId xs t' number = showHtml $ mkheader (entryTitle (head xs)) +++ body << thediv ! [theclass "wrapper"] << (h1 << thespan << "hpaste" +++ thediv ! [theclass "topnav"] << (hotlink "/" << "recent" +++ " | " +++ hotlink ("/annotate/" ++ show entryId) << "annotate" +++ " | " +++ hotlink "/new" << "new" ) +++ [ hr +++ thediv ! [theclass "pasteEntry"] << (ulist ! [theclass "pasteHeader"] << ( li << (thespan ! [theclass "nickLabel"] << entryNick x) +++ li << (thespan ! [theclass "entryLabel"] << entryTitle x) +++ li << (thespan ! [theclass "entryTime"] << formatTime t' (entryTime x)) ) +++ ulist ! [theclass "pasteLinks"] << (li << hotlink (printf "/%d/%d/plain" entryId n) << "raw" +++ li << anchor ! [href ("#" ++ show n), name (show n)] << oneWord "link" +++ li << hotlink (printf "/annotate/%d?oldId=%d" entryId n) << oneWord "annotate" ) ) +++ ( 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"] << noHtml) ) 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 . ("
"++) . 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"]
    << (h1 << thespan << "hpaste" +++
        thediv ! [theclass "topnav"]
        << (hotlink "/" << "recent" +++ " | " +++
            hotlink "/new" << "new" +++ " | " +++
            hotlink ("/" ++ show entryId) << "normal"
           ) +++
        hr +++
        thediv ! [theclass "pasteEntry"]
        << (ulist ! [theclass "pasteHeader"]
            << (li << (thespan ! [theclass "fromLabel"] << "Old:" +++
                       ' ' : entryTitle xs) +++
                li << (thespan ! [theclass "toLabel"] << "New:" +++
                       ' ' : entryTitle ys)
               ) +++
            ulist ! [theclass "pasteLinks"]
            << li << hotlink "#" << "link"
           ) +++
        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

oneWord :: String -> Html
oneWord = concatHtml . intersperse spaceHtml . map toHtml . words

readDefault :: Read s => s -> String -> s
readDefault def xs = case reads xs of
                       [(x,"")] -> x
                       _        -> def