diff --git a/DiffHtml.hs b/DiffHtml.hs
new file mode 100644
--- /dev/null
+++ b/DiffHtml.hs
@@ -0,0 +1,91 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : DiffHtml
+-- Copyright : (c) Eric Mertens 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : emertens@gmail.com
+-- Stability : unstable
+-- Portability : portable
+--
+-----------------------------------------------------------------------------
+--
+-- The DiffHtml printer
+--
+
+module DiffHtml (htmlDiff, textDiff) where
+
+import Data.Array
+import Text.XHtml.Strict hiding ((!))
+import qualified Text.XHtml.Strict as X
+import qualified Data.ByteString.Char8 as B
+
+tabulate :: (Ix a) => (a,a) -> (a -> b) -> Array a b
+tabulate bs f = array bs [(i,f i) | i <- range bs]
+
+dp :: (Ix a) => (a,a) -> ((a->b) -> a -> b) -> a -> b
+dp bs f = (memo!)
+ where memo = tabulate bs (f (memo!))
+
+textDiff :: [Char] -> [Char] -> [Char]
+textDiff xs ys = xs `seq` ys `seq` concat $ map convert $ lcs xs ys
+ where
+ convert (YPart y) = " +" ++ [y]
+ convert (XPart x) = " -" ++ [x]
+ convert (MatchPart m) = " " ++ [m]
+
+-- | Diff two bytestrings, render as html
+htmlDiff :: B.ByteString -> B.ByteString -> Html
+htmlDiff xs ys
+ = xs `seq` ys `seq` primHtml
+ . unlines
+ . map (show . convertDiff) .
+ lcs (B.lines xs) $ (B.lines ys)
+
+-- | Mark up a diff
+convertDiff :: DiffRes B.ByteString -> Html
+convertDiff (YPart y) = pprDiff "addsub" "+ " y
+convertDiff (XPart x) = pprDiff "delsub" "- " x
+convertDiff (MatchPart m) = pprDiff "matchsub" " " m
+
+-- | And render it
+pprDiff :: String -> [Char] -> B.ByteString -> Html
+pprDiff c q t = (X.!) thespan [theclass c] << primHtml (q ++ B.unpack t)
+
+------------------------------------------------------------------------
+
+data DiffRes a = YPart !a | XPart !a | MatchPart !a
+ deriving (Ord, Eq)
+
+lcs :: Ord a => [a] -> [a] -> [DiffRes a]
+{-# SPECIALIZE lcs :: [B.ByteString] -> [B.ByteString] -> [DiffRes B.ByteString] #-}
+lcs xs ys = snd $ longest lenx leny xarr yarr (0,0)
+ where
+ lenx = length xs
+ leny = length ys
+ xarr = listArray (0,lenx-1) xs
+ yarr = listArray (0,leny-1) ys
+
+longest :: Ord a
+ => Int -> Int
+ -> Array Int a
+ -> Array Int a -> (Int, Int)
+ -> (Int, [DiffRes a])
+longest a b c d| a `seq` b `seq` c `seq` d `seq` False = undefined
+longest lenx leny xarr yarr = dp ((0,0),(lenx,leny)) f
+ where
+ f rec (x,y)
+ | x'ge'lenx && y'ge'leny = (0, [])
+ | x'ge'lenx = y'
+ | y'ge'leny = x'
+ | xarr ! x == yarr ! y = max (match $ rec (x+1,y+1)) m
+ | otherwise = m
+ where
+ m = max y' x'
+ x'ge'lenx = x >= lenx
+ y'ge'leny = y >= leny
+
+ y' = miss (YPart (yarr ! y)) $ rec (x,y+1)
+ x' = miss (XPart (xarr ! x)) $ rec (x+1,y)
+ match (n,xs) = (n+1,(MatchPart (yarr ! y)):xs)
+ miss z (n,xs) = (n,z:xs)
diff --git a/HPaste.hs b/HPaste.hs
new file mode 100644
--- /dev/null
+++ b/HPaste.hs
@@ -0,0 +1,555 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,32 @@
+HPaste
+
+Copyright (c) Eric Mertens
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/PasteBot.hs b/PasteBot.hs
new file mode 100644
--- /dev/null
+++ b/PasteBot.hs
@@ -0,0 +1,213 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : PasteBot
+-- Copyright : (c) Eric Mertens 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : emertens@gmail.com
+-- Stability : unstable
+-- Portability : portable
+--
+-----------------------------------------------------------------------------
+--
+-- HPaste irc announce bot
+--
+
+module PasteBot (runBot, PasteAnnounce (..)) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Reader
+import Data.Char (isSpace)
+import Data.List
+import Network
+import Prelude hiding (catch)
+import System.IO
+import System.Exit
+import Text.ParserCombinators.ReadP
+import Text.Printf
+
+server :: String
+server = "irc.se.freenode.net"
+
+port :: PortID
+port = PortNumber 6666
+
+chan :: String
+chan = "#haskell"
+
+nick :: String
+nick = "hpaste"
+
+admin :: String
+admin = ":glguy!n=eric@unaffiliated/glguy"
+
+announceurl :: String
+announceurl = "Haskell paste bin: http://hpaste.org/"
+
+-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
+
+type Net = ReaderT Bot IO
+data Bot = Bot { socket :: Handle, messages :: Chan PasteAnnounce
+ , modeVar :: MVar BotMode}
+
+data BotMode = BotMode { isSilenced :: Bool, adminList :: [String] }
+
+data PasteAnnounce = NewPaste String String String
+ | Annotation String String String String
+
+instance Show PasteAnnounce where
+ show (NewPaste n t u) = printf " %s pasted \"%s\" at %s" n t u
+ show (Annotation n t t' u)
+ = printf " %s annotated \"%s\" with \"%s\" at %s" n t t' u
+
+forever :: Monad m => m a -> m b
+forever a = a >> forever a
+
+initBotMode :: BotMode
+initBotMode = BotMode { isSilenced = False
+ , adminList = []
+ }
+
+-- Set up actions to run on start and end, and run the main loop
+
+runBot :: Chan PasteAnnounce -> IO ()
+runBot ch = bracket (connect ch) disconnect loop
+ where
+ disconnect = hClose . socket
+ loop b = do
+ forkIO $ runReaderT chanListener b
+ handle (\_ -> return()) $ runReaderT run b
+
+-- Connect to the server and return the initial bot state
+
+connect :: Chan PasteAnnounce -> IO Bot
+connect ch = notify $ do
+ h <- connectTo server port
+ bmodeVar <- newMVar initBotMode
+ hSetBuffering h NoBuffering
+ return $ Bot h ch bmodeVar
+ where
+ notify = bracket_
+ (printf "Connecting to %s ... " server >> hFlush stdout)
+ (putStrLn "done.")
+
+chanListener :: Net b
+chanListener = do
+ ch <- asks messages
+ var <- asks modeVar
+ forever $ do
+ msg <- io $ readChan ch
+ mode <- io $ readMVar var
+ unless (isSilenced mode) $
+ privmsg $ show msg
+
+-- We're in the Net monad now, so we've connected successfully
+
+-- Join a channel, and start processing commands
+
+run :: Net ()
+run = do
+ write "NICK" nick
+ write "USER" (nick ++ " 0 * :announcer")
+ write "JOIN" chan
+ listen
+
+-- Process each line from the server
+
+listen :: Net ()
+listen = do
+ h <- asks socket
+ forever $ do
+ s <- io $ liftM init $ hGetLine h -- remove newline
+ io $ putStrLn s
+ if ping s then pong s else isAdmin s >>= eval s
+ where
+ ping x = "PING :" `isPrefixOf` x
+ pong x = write "PONG" $ dropWord x
+ isAdmin s = do
+ var <- asks modeVar
+ admins <- io $ liftM adminList $ readMVar var
+ return $ admin `isPrefixOf` s || any (`isPrefixOf` s) admins
+
+-- Dispatch a command
+
+urlParser :: ReadS String
+urlParser = readP_to_S $ do
+ string nick
+ optional $ choice [char ':', char ',']
+ skipSpaces
+ string "url"
+
+eval :: String -> Bool -> Net ()
+eval s isAdmin
+ | ("!paste" `isPrefixOf` s' || (not $ null $ urlParser s'))
+ && (isAdmin || ws !! 2 == chan)
+ = privmsg announceurl
+
+ | isAdmin = case () of
+ _ | "!quit" `isPrefixOf` s' -> do
+ write "QUIT" ":Exiting"
+ io (exitWith ExitSuccess)
+
+ | "!say " `isPrefixOf` s' -> privmsg (dropWord s')
+
+ | "!msg " `isPrefixOf` s' -> privmsgTo (dropWord s')
+
+ | "!quiet" `isPrefixOf` s' -> setSilenced True
+
+ | "!verbose" `isPrefixOf` s' -> setSilenced False
+
+ | "!admin+ " `isPrefixOf` s' -> addAdmin (dropWord s')
+
+ | "!admin- " `isPrefixOf` s' -> dropAdmin (dropWord s')
+
+ | otherwise -> return ()
+
+ | otherwise = return ()
+
+ where
+ clean = drop 1 . dropWhile (/= ':') . drop 1
+ s' = clean s
+ ws = words s
+
+ setSilenced b = do
+ var <- asks modeVar
+ io $ modifyMVar_ var (\m -> return $ m { isSilenced = b })
+
+ addAdmin n = do
+ var <- asks modeVar
+ io $ modifyMVar_ var (\m -> return $ m { adminList = n : adminList m})
+
+ dropAdmin n = do
+ var <- asks modeVar
+ io $ modifyMVar_ var
+ (\m -> return $ m { adminList = n `delete` adminList m})
+
+-- Send a privmsg to the current chan + server
+
+privmsg :: String -> Net ()
+privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)
+
+-- Send a privmsg to the specified user
+
+privmsgTo :: String -> Net ()
+privmsgTo s = write "PRIVMSG" s
+
+-- Send a message out to the server we're currently connected to
+
+write :: String -> String -> Net ()
+write s t = do
+ h <- asks socket
+ io $ hPrintf h "%s %s\r\n" s t
+ io $ printf "> %s %s\n" s t
+
+-- Convenience.
+
+io :: IO a -> Net a
+io = liftIO
+
+-- Utility function
+
+dropWord :: String -> String
+dropWord = dropWhile isSpace . dropWhile (not . isSpace)
diff --git a/PasteState.hs b/PasteState.hs
new file mode 100644
--- /dev/null
+++ b/PasteState.hs
@@ -0,0 +1,139 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : PasteState
+-- Copyright : (c) Eric Mertens 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : emertens@gmail.com
+-- Stability : unstable
+-- Portability : portable
+--
+-----------------------------------------------------------------------------
+--
+-- The basic state of the paste server
+--
+
+module PasteState (
+ currentId
+ , PasteState
+ , Entry
+ , entryNick
+ , entryTitle
+ , entryContent
+ , entryTime
+ , getEntries
+ , storeEntry
+ , storeAnnotation
+ , allEntries
+ , newEntry
+
+ , TimeStamp
+
+ , gzip
+ , gunzip
+ ) where
+
+import HAppS (StartState(..), Serialize(..))
+
+import qualified Data.Sequence as S
+import qualified Data.Foldable as F
+import Data.Int
+import Data.List
+import Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import Control.Monad
+
+import Data.Binary
+import Codec.Compression.GZip
+
+------------------------------------------------------------------------
+
+newtype GZBytestring = GZ B.ByteString
+
+-- | The PasteState, the state of our system
+data PasteState = PasteState !(S.Seq [Entry])
+
+-- | An individual paste
+data Entry = MkEntry2
+ { entryNick, entryTitle :: !String
+ , entryContentGz :: !GZBytestring -- a compressed in-memory bytestring
+ , entryTime :: !Int64 }
+
+-- | Uncompress a content field on the fly
+entryContent :: Entry -> B.ByteString
+entryContent e = gunzip gz
+ where GZ gz = entryContentGz e
+
+--
+-- Fast serialisation using Data.Binary
+--
+instance Binary PasteState where
+ put (PasteState xs) = put xs
+ get = liftM PasteState get
+
+instance Binary Entry where
+ put (MkEntry2 nk ti cn tm) = put nk >> put ti >> put cn >> put tm
+ get = liftM4 MkEntry2 get get get get
+
+-- | Write out a raw compressed bytestring
+instance Binary GZBytestring where
+ put (GZ b) = put b
+ get = liftM GZ get
+-- migration:
+-- get = do b <- get ; return (GZ (gzip b))
+
+------------------------------------------------------------------------
+
+-- | Compress a strict ByteString
+gzip :: B.ByteString -> B.ByteString
+gzip = B.concat . L.toChunks . compress . L.fromChunks . (:[])
+
+-- | Uncompress a strict ByteString
+gunzip :: B.ByteString -> B.ByteString
+gunzip = B.concat . L.toChunks . decompress . L.fromChunks . (:[])
+
+------------------------------------------------------------------------
+
+-- | Serialisation of the server state
+instance StartState PasteState where
+ startStateM = return $ PasteState $ S.empty
+
+instance Serialize PasteState where
+ typeString _ = "PasteState_0"
+
+ -- Compress everything. Currently has to go via String :(
+ encodeFPS a = return . L.toChunks . compress . encode $ a
+ encodeStringM a = return . L.unpack . compress . encode $ a
+ decodeStringM s = L.length ps `seq` return (decode (decompress ps), "")
+ where ps = L.pack s
+
+------------------------------------------------------------------------
+
+-- | A convenient alias for time
+type TimeStamp = Int64
+
+------------------------------------------------------------------------
+
+-- | Build a new entry. Shallow wrapper over the Entry constructor
+-- Compreses the input bytestring using gzip.
+newEntry :: String -> String -> ByteString -> TimeStamp -> Entry
+newEntry nick title content t = MkEntry2 nick title (GZ contentgz) t
+ where contentgz = gzip . B.filter (/='\r') $ content
+
+-- | The current user id (this is a unique supply..)
+currentId :: PasteState -> Int
+currentId (PasteState s) = fromIntegral $ S.length s
+
+allEntries :: PasteState -> [(Int, [Entry])]
+allEntries (PasteState s) = Prelude.zip [n,n-1..] $ F.toList $ S.reverse s
+ where n = S.length s - 1
+
+getEntries :: Int -> PasteState -> [Entry]
+getEntries n (PasteState s) = S.index s n
+
+storeEntry :: Entry -> PasteState -> PasteState
+storeEntry e (PasteState s) = PasteState $ (S.|>) s [e]
+
+storeAnnotation :: Int -> Entry -> PasteState -> PasteState
+storeAnnotation n e (PasteState s)
+ = PasteState $ S.update n (S.index s n ++ [e]) s
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,27 @@
+hpaste: Haskell pastebin
+
+Dependencies:
+ mtl http://hackage.haskell.org/packages/archive/mtl/mtl-1.0.tar.gz
+ network http://hackage.haskell.org/packages/archive/network/network-2.0.tar.gz
+ hscolour >= 1.6 http://hackage.haskell.org/packages/archive/hscolour/hscolour-1.6.tar.gz
+ binary >= 0.2 http://hackage.haskell.org/packages/archive/binary/binary-0.2.tar.gz
+ zlib http://hackage.haskell.org/packages/archive/zlib/zlib-0.3.tar.gz
+
+ xhtml darcs version of xhtml
+ HAppS > 0.8.4 darcs version of HAppS
+
+Download these and build them.
+
+Building:
+ runhaskell Setup.hs configure --prefix=/foo/bar
+ runhaskell Setup.hs build
+ runhaskell Setup.hs install
+
+Running:
+ hpaste
+
+Contributors:
+ Eric Mertens
+ Stefan O'Rear
+ Don Stewart
+ sanzhiyan@gmail.com
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/hpaste.cabal b/hpaste.cabal
--- a/hpaste.cabal
+++ b/hpaste.cabal
@@ -1,56 +1,15 @@
-Name: hpaste
-Version: 0.0.0
-stability: Stable
-Synopsis: Haskell paste web site.
-Description: Haskell paste web site.
-Homepage: http://hpaste.org/
-License: GPL
-Author: Chris Done
-Maintainer: Chris Done
-Copyright: 2010-2013 by Chris Done
-Category: Web
-Build-type: Simple
-Cabal-version: >=1.2
+name: hpaste
+version: 0.3
+description: Haskell pastebin, using HAppS
+synopsis: An online pastebin, written in Haskell.
+license: BSD3
+license-file: LICENSE
+category: Web
+author: Eric Mertens
+maintainer: emertens@gmail.com
+homepage: http://hpaste.org
+build-depends: base, HAppS > 0.8.4, xhtml, mtl, network, hscolour >= 1.6, binary >= 0.2, zlib
-Executable hpaste
- Main-is: Main.hs
- Ghc-options: -threaded -Wall -O2 -fno-warn-name-shadowing
- Hs-source-dirs: src
- Build-depends:
- -- Hard versions
- Diff == 0.1.3
- ,blaze-html == 0.4.3.4
- -- Soft versions
- ,base >= 4 && < 5
- ,css >= 0.1
- ,named-formlet >= 0.2
- ,snap-app >= 0.3.2
- -- Free versions
- ,ConfigFile
- ,HJScript
- ,MissingH
- ,MonadCatchIO-transformers
- ,blaze-builder
- ,bytestring
- ,containers
- ,directory
- ,download-curl
- ,feed
- ,filepath
- ,haskell-src-exts
- ,hlint
- ,hscolour
- ,mtl
- ,network
- ,old-locale
- ,safe
- ,snap-core
- ,snap-server
- ,text
- ,time
- ,transformers
- ,utf8-string
- ,mime-mail
- ,cgi
- ,process
- ,postgresql-simple
+executable: hpaste
+main-is: HPaste.hs
+ghc-options: -Wall -O -funbox-strict-fields -fasm -optl-Wl,-s
diff --git a/hpaste.css b/hpaste.css
new file mode 100644
--- /dev/null
+++ b/hpaste.css
@@ -0,0 +1,49 @@
+.fromLabel, span.delsub { background-color: #fcc }
+.toLabel, span.addsub { background-color: #cfc }
+a, p.footer a, p.footer a:hover { color: #004488 }
+a, p.footer a, table.pastes a, ul.pasteLinks li { text-decoration: none }
+a:hover, p.footer a:hover { text-decoration: underline }
+body { font-family: Lucida Grande , Verdana , Arial , Sans-Serif }
+body, button, tr.pastes:hover { background-color: white }
+body, div.wrapper { position: relative }
+body, h1 { margin: 1.0em auto }
+body, h1, hr, table.pastes, textarea { width: 100.0% }
+button { background: url(/static/blank.jpg) no-repeat center; height: 16px; width: 74px }
+button, fieldset, hr { border: 0.0 }
+button, p.footer { text-align: center }
+button, span.addsub:first-letter, span.delsub:first-letter { color: white }
+div.clear, pre, ul.pasteLinks { clear: both }
+div.pager { margin: 0.25em 0.0 }
+div.pasteforms fieldset { height: 1.0em }
+div.pasteforms fieldset, ul.pasteHeader li { float: left }
+div.pasteforms fieldset.left, ul.pasteLinks li { margin-right: 1.0em }
+div.topnav { margin-bottom: 1.0em }
+div.topnav a { padding: 2px }
+div.wrapper { width: 90.0% }
+div.wrapper, table.pastes { margin: auto }
+h1 { background: url(/static/hpaste.jpg) no-repeat left; height: 27px }
+h1 span { display: none; font-size: 130.0% }
+hr { background-color: #888; height: 1px }
+hr, span.comment, span.comment a { color: #888 }
+input, select { border: 1px solid silver }
+label { font-size: 90.0%; margin-right: 0.5em }
+p.footer { color: black; font-size: smaller; margin-top: 1.0em }
+pre { overflow: auto; padding: 2.0em }
+pre, select, table.pastes, textarea { background-color: #f8f8f8 }
+pre, table.pastes, textarea { border: 1px solid black }
+span.chr, span.conop, span.num, span.str, span.varop { color: teal }
+span.keyglyph, span.keyword, span.layout { color: #5736aB }
+table.pastes { border-collapse: collapse; cursor: pointer }
+table.pastes a { color: #048; padding: 1px }
+table.pastes a, textarea { display: block }
+table.pastes td { border-top: 1px dotted #ddd }
+table.pastes td, table.pastes th { text-align: right }
+table.pastes td, ul.pasteHeader li, ul.pasteLinks li { padding: 2px 5px }
+table.pastes th { font-weight: bold }
+table.pastes, ul.pasteHeader, ul.pasteLinks { padding: 0.0 }
+textarea { background-color: #fefefe }
+ul.pasteHeader li { margin-right: 5px }
+ul.pasteHeader li, ul.pasteLinks li, ul.pasteLinks li a { display: inline }
+ul.pasteHeader span.entryLabel { font-style: italic }
+ul.pasteHeader, ul.pasteLinks { list-style-type: none; margin: 0.0 }
+ul.pasteLinks { font-size: 80.0% }
diff --git a/images/blank.jpg b/images/blank.jpg
new file mode 100644
Binary files /dev/null and b/images/blank.jpg differ
diff --git a/images/hpaste.jpg b/images/hpaste.jpg
new file mode 100644
Binary files /dev/null and b/images/hpaste.jpg differ
diff --git a/images/save.jpg b/images/save.jpg
new file mode 100644
Binary files /dev/null and b/images/save.jpg differ
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
--- a/src/Main.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-{-# OPTIONS -Wall #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Main entry point.
-
-module Main (main) where
-
-import Hpaste.Config
-import Hpaste.Controller.Activity as Activity
-import Hpaste.Controller.Browse as Browse
-import Hpaste.Controller.Diff as Diff
-import Hpaste.Controller.Home as Home
-import Hpaste.Controller.New as New
-import Hpaste.Controller.Paste as Paste
-import Hpaste.Controller.Raw as Raw
-import Hpaste.Controller.Report as Report
-import Hpaste.Controller.Reported as Reported
-import Hpaste.Controller.Style as Style
-import Hpaste.Controller.Script as Script
-import Hpaste.Model.Announcer (newAnnouncer)
-import Hpaste.Types
-import Hpaste.Types.Announcer
-
-import Control.Concurrent.Chan (Chan)
-import Data.Text.Lazy (Text)
-import System.Environment
-import Snap.App
-import Snap.Http.Server hiding (Config)
-import Snap.Util.FileServe
-
-
--- | Main entry point.
-main :: IO ()
-main = do
- cpath:_ <- getArgs
- config <- getConfig cpath
- announces <- newAnnouncer (configAnnounce config)
- pool <- newPool (configPostgres config)
- setUnicodeLocale "en_US"
- httpServe server (serve config pool announces)
- where server = setPort 10000 defaultConfig
-
--- | Serve the controllers.
-serve :: Config -> Pool -> Announcer -> Snap ()
-serve config pool ans = route routes where
- routes = [("/css/amelie.css", run Style.handle)
- ,("/css/",serveDirectory "static/css")
- ,("/js/amelie.js",run Script.handle)
- ,("/js/",serveDirectory "static/js")
- ,("/hs/",serveDirectory "static/hs")
- ,("",run (Home.handle False))
- ,("/spam",run (Home.handle True))
- ,("/:id",run (Paste.handle False))
- ,("/raw/:id",run Raw.handle)
- ,("/revision/:id",run (Paste.handle True))
- ,("/report/:id",run Report.handle)
- ,("/reported",run Reported.handle)
- ,("/new",run (New.handle New.NewPaste))
- ,("/annotate/:id",run (New.handle New.AnnotatePaste))
- ,("/edit/:id",run (New.handle New.EditPaste))
- ,("/new/:channel",run (New.handle New.NewPaste))
- ,("/browse",run Browse.handle)
- ,("/activity",run Activity.handle)
- ,("/diff/:this/:that",run Diff.handle)
- ,("/delete",run Report.handleDelete)
- ]
- run = runHandler ans config pool