diff --git a/DiffHtml.hs b/DiffHtml.hs
deleted file mode 100644
--- a/DiffHtml.hs
+++ /dev/null
@@ -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)
diff --git a/HPaste.hs b/HPaste.hs
deleted file mode 100644
--- a/HPaste.hs
+++ /dev/null
@@ -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 . (""++) . 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
deleted file mode 100644
--- a/LICENSE
+++ /dev/null
@@ -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.
diff --git a/PasteBot.hs b/PasteBot.hs
deleted file mode 100644
--- a/PasteBot.hs
+++ /dev/null
@@ -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)
diff --git a/PasteState.hs b/PasteState.hs
deleted file mode 100644
--- a/PasteState.hs
+++ /dev/null
@@ -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
diff --git a/README b/README
deleted file mode 100644
--- a/README
+++ /dev/null
@@ -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
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
deleted file mode 100644
--- a/Setup.lhs
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/usr/bin/env runhaskell
-> import Distribution.Simple
-> main = defaultMain
diff --git a/hpaste.cabal b/hpaste.cabal
--- a/hpaste.cabal
+++ b/hpaste.cabal
@@ -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
+Maintainer: Chris Done
+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
diff --git a/hpaste.css b/hpaste.css
deleted file mode 100644
--- a/hpaste.css
+++ /dev/null
@@ -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% }
diff --git a/images/blank.jpg b/images/blank.jpg
deleted file mode 100644
Binary files a/images/blank.jpg and /dev/null differ
diff --git a/images/hpaste.jpg b/images/hpaste.jpg
deleted file mode 100644
Binary files a/images/hpaste.jpg and /dev/null differ
diff --git a/images/save.jpg b/images/save.jpg
deleted file mode 100644
Binary files a/images/save.jpg and /dev/null differ
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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