hpaste-0.3: HPaste.hs
-----------------------------------------------------------------------------
-- |
-- 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 . ("<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"]
<< (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