hpaste 0.3 → 1.0.0
raw patch · 14 files changed
+128/−1123 lines, 14 filesdep +ConfigFiledep +Diffdep +HJScriptdep −HAppSdep −binarydep −xhtmldep ~basedep ~hscoloursetup-changed
Dependencies added: 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
Dependencies removed: HAppS, binary, xhtml, zlib
Dependency ranges changed: base, hscolour
Files
- DiffHtml.hs +0/−91
- HPaste.hs +0/−555
- LICENSE +0/−32
- PasteBot.hs +0/−213
- PasteState.hs +0/−139
- README +0/−27
- Setup.hs +2/−0
- Setup.lhs +0/−3
- hpaste.cabal +59/−14
- hpaste.css +0/−49
- images/blank.jpg binary
- images/hpaste.jpg binary
- images/save.jpg binary
- src/Main.hs +67/−0
− DiffHtml.hs
@@ -1,91 +0,0 @@--------------------------------------------------------------------------------- |--- 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
@@ -1,555 +0,0 @@--------------------------------------------------------------------------------- |--- 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
@@ -1,32 +0,0 @@-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
@@ -1,213 +0,0 @@--------------------------------------------------------------------------------- |--- 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
@@ -1,139 +0,0 @@--------------------------------------------------------------------------------- |--- 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
@@ -1,27 +0,0 @@-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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
hpaste.cabal view
@@ -1,15 +1,60 @@-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+Name: hpaste+Version: 1.0.0+stability: Stable+Synopsis: Haskell paste web site.+Description: Haskell paste web site. Includes: syntax highlighting for+ various languages, HLint suggestions for Haskell, annotations,+ revisions, diffs between revisions, announcement to IRC channels,+ browsing of author's pastes, spam reporting/deletion,+ SpamAssassin-based spam protection, secret/private pastes.+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 -executable: hpaste-main-is: HPaste.hs-ghc-options: -Wall -O -funbox-strict-fields -fasm -optl-Wl,-s+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
− hpaste.css
@@ -1,49 +0,0 @@-.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
binary file changed (1102 → absent bytes)
− images/hpaste.jpg
binary file changed (8062 → absent bytes)
− images/save.jpg
binary file changed (1565 → absent bytes)
+ src/Main.hs view
@@ -0,0 +1,67 @@+{-# 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