hpaste 0.0.0 → 0.3
raw patch · 14 files changed
+1123/−124 lines, 14 filesdep +HAppSdep +binarydep +xhtmldep −ConfigFiledep −Diffdep −HJScriptdep ~basedep ~hscolourbuild-type:Customsetup-changednew-uploaderbinary-added
Dependencies added: HAppS, binary, xhtml, zlib
Dependencies removed: ConfigFile, Diff, HJScript, MissingH, MonadCatchIO-transformers, blaze-builder, blaze-html, bytestring, cgi, containers, css, directory, download-curl, feed, filepath, haskell-src-exts, hlint, mime-mail, named-formlet, old-locale, postgresql-simple, process, safe, snap-app, snap-core, snap-server, text, time, transformers, utf8-string
Dependency ranges changed: base, hscolour
Files
- DiffHtml.hs +91/−0
- HPaste.hs +555/−0
- LICENSE +32/−0
- PasteBot.hs +213/−0
- PasteState.hs +139/−0
- README +27/−0
- Setup.hs +0/−2
- Setup.lhs +3/−0
- hpaste.cabal +14/−55
- hpaste.css +49/−0
- images/blank.jpg binary
- images/hpaste.jpg binary
- images/save.jpg binary
- src/Main.hs +0/−67
+ DiffHtml.hs view
@@ -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)
+ HPaste.hs view
@@ -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 . ("<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
+ LICENSE view
@@ -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.
+ PasteBot.hs view
@@ -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)
+ PasteState.hs view
@@ -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
+ README view
@@ -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
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
hpaste.cabal view
@@ -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 <chrisdone@gmail.com>-Maintainer: Chris Done <chrisdone@gmail.com>-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
+ hpaste.css view
@@ -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% }
+ images/blank.jpg view
binary file changed (absent → 1102 bytes)
+ images/hpaste.jpg view
binary file changed (absent → 8062 bytes)
+ images/save.jpg view
binary file changed (absent → 1565 bytes)
− src/Main.hs
@@ -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