├── Setup.hs ├── static ├── favicon.ico ├── css │ ├── hpaste.png │ └── amelie.css ├── hpaste.el ├── hs │ └── stepeval-prelude.hs └── js │ ├── amelie.js │ └── highlight-haskell.js ├── scripts ├── cron-update ├── start └── server-restart ├── .gitignore ├── src ├── Control │ └── Monad │ │ ├── IO.hs │ │ ├── Catch.hs │ │ └── Env.hs ├── Data │ ├── Monoid │ │ └── Operator.hs │ ├── Maybe │ │ └── Extra.hs │ ├── Text │ │ ├── FromText.hs │ │ └── ToText.hs │ ├── Time │ │ ├── Show.hs │ │ └── Relative.hs │ ├── Either │ │ └── Extra.hs │ └── String │ │ ├── Extra.hs │ │ └── ToString.hs ├── Snap │ └── App.hs ├── Hpaste │ ├── Types │ │ ├── Activity.hs │ │ ├── Page.hs │ │ ├── Stepeval.hs │ │ ├── Cache.hs │ │ ├── Channel.hs │ │ ├── Announcer.hs │ │ ├── Language.hs │ │ ├── Report.hs │ │ ├── Config.hs │ │ ├── Newtypes.hs │ │ └── Paste.hs │ ├── Model │ │ ├── Channel.hs │ │ ├── Language.hs │ │ ├── Activity.hs │ │ ├── Announcer.hs │ │ ├── Report.hs │ │ ├── Spam.hs │ │ ├── Irclogs.hs │ │ └── Paste.hs │ ├── Controller │ │ ├── Script.hs │ │ ├── Diff.hs │ │ ├── Reported.hs │ │ ├── Activity.hs │ │ ├── Browse.hs │ │ ├── Raw.hs │ │ ├── Irclogs.hs │ │ ├── Home.hs │ │ ├── Admin.hs │ │ ├── Rss.hs │ │ ├── New.hs │ │ ├── Report.hs │ │ ├── Cache.hs │ │ └── Paste.hs │ ├── View │ │ ├── New.hs │ │ ├── Edit.hs │ │ ├── Annotate.hs │ │ ├── Thanks.hs │ │ ├── Activity.hs │ │ ├── Hlint.hs │ │ ├── Reported.hs │ │ ├── Irclogs.hs │ │ ├── Diff.hs │ │ ├── Report.hs │ │ ├── Home.hs │ │ ├── Script.hs │ │ ├── Stepeval.hs │ │ ├── Browse.hs │ │ ├── Layout.hs │ │ ├── Steps.hs │ │ ├── Highlight.hs │ │ ├── Html.hs │ │ └── Paste.hs │ ├── Types.hs │ └── Config.hs ├── Text │ └── Blaze │ │ └── Html5 │ │ └── Extra.hs ├── Network │ ├── URI │ │ └── Params.hs │ ├── Email.hs │ └── SendEmail.hs ├── Main.hs └── HJScript │ └── Objects │ └── JQuery │ └── Extra.hs ├── README.md ├── amelie.conf.sample ├── hpaste.conf.sample ├── hpaste.cabal └── sql └── schema.sql /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /static/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alpmestan/lpaste/master/static/favicon.ico -------------------------------------------------------------------------------- /static/css/hpaste.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alpmestan/lpaste/master/static/css/hpaste.png -------------------------------------------------------------------------------- /scripts/cron-update: -------------------------------------------------------------------------------- 1 | cd /home/chris/hpaste 2 | logger -t hpaste "Clearing cache ..." 3 | rm cache/* 4 | rm log/* -------------------------------------------------------------------------------- /scripts/start: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | cd /home/chris/hpaste/ 3 | mkdir log -p 4 | dist/build/hpaste/hpaste hpaste.conf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | log 4 | src/TAGS 5 | *.hi 6 | *.o 7 | amelie.conf 8 | irclogs 9 | cache/ 10 | TAGS 11 | .hsenv/ 12 | hpaste.conf -------------------------------------------------------------------------------- /src/Control/Monad/IO.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | module Control.Monad.IO where 4 | 5 | import Control.Monad.Trans 6 | 7 | io :: MonadIO m => IO a -> m a 8 | io = liftIO 9 | -------------------------------------------------------------------------------- /src/Data/Monoid/Operator.hs: -------------------------------------------------------------------------------- 1 | -- | Convenient operator. 2 | 3 | module Data.Monoid.Operator where 4 | 5 | import Data.Monoid 6 | 7 | (++) :: (Monoid a) => a -> a -> a 8 | (++) = mappend -------------------------------------------------------------------------------- /scripts/server-restart: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | mkdir log -p 4 | echo 'Killing ...' 5 | killall hpaste 6 | sleep 0.2 7 | echo 'Starting ...' 8 | dist/build/hpaste/hpaste hpaste.conf & disown 9 | -------------------------------------------------------------------------------- /src/Control/Monad/Catch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | module Control.Monad.Catch (module Control.Monad.CatchIO) where 4 | 5 | import "MonadCatchIO-transformers" Control.Monad.CatchIO 6 | -------------------------------------------------------------------------------- /src/Snap/App.hs: -------------------------------------------------------------------------------- 1 | module Snap.App 2 | (module Snap.Core 3 | ,module Snap.App.Types 4 | ,module Snap.App.Controller 5 | ,module Snap.App.Model) 6 | where 7 | 8 | import Snap.Core 9 | import Snap.App.Types 10 | import Snap.App.Controller 11 | import Snap.App.Model 12 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Activity.hs: -------------------------------------------------------------------------------- 1 | module Hpaste.Types.Activity where 2 | 3 | import Data.Text.Lazy (Text) 4 | import Data.Time (UTCTime) 5 | 6 | data Commit = Commit { 7 | commitTitle :: Text 8 | ,commitContent :: Text 9 | ,commitDate :: UTCTime 10 | ,commitLink :: Text 11 | } deriving Show -------------------------------------------------------------------------------- /src/Data/Maybe/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Data.Maybe.Extra where 5 | 6 | -- | When a value is Just, do something with it, monadically. 7 | whenJust :: Monad m => Maybe a -> (a -> m c) -> m () 8 | whenJust (Just a) m = m a >> return () 9 | whenJust _ _ = return () 10 | -------------------------------------------------------------------------------- /src/Data/Text/FromText.hs: -------------------------------------------------------------------------------- 1 | module Data.Text.FromText where 2 | 3 | import Data.Text 4 | import qualified Data.Text.Lazy as L 5 | import Data.ByteString 6 | import qualified Data.ByteString.Lazy as L 7 | 8 | class FromText a where 9 | fromText :: Text -> Maybe a 10 | fromLazyText :: L.Text -> Maybe a 11 | fromLazyText = fromText . L.toStrict 12 | -------------------------------------------------------------------------------- /src/Text/Blaze/Html5/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Text.Blaze.Html5.Extra where 5 | 6 | import Text.Blaze.Html5 as H 7 | import qualified Text.Blaze.Html5.Attributes as A 8 | 9 | -- | A POST form. 10 | postForm :: Html -> Html 11 | postForm = H.form ! A.method "POST" 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Database setup 2 | 3 | $ sudo su postgres --command 'createuser hpaste -P' 4 | $ sudo su postgres --command 'createdb hpaste -O hpaste' 5 | $ cat sql/schema.sql | psql -U hpaste -h 127.0.0.1 -d hpaste 6 | 7 | ## Configuration & Running 8 | 9 | $ cp hpaste.conf.sample hpaste.conf 10 | 11 | Edit hpaste.conf. 12 | 13 | $ dist/build/hpaste/hpaste hpaste.conf 14 | 15 | -------------------------------------------------------------------------------- /src/Control/Monad/Env.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Abstraction of environment functions (could be state, could be 5 | -- reader, whatever). Intended to ease migration from Reader/State. 6 | 7 | module Control.Monad.Env 8 | (env) 9 | where 10 | 11 | import Control.Monad.Reader 12 | 13 | env :: MonadReader env m => (env -> val) -> m val 14 | env = asks 15 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Page.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | The page type. 5 | 6 | module Hpaste.Types.Page 7 | (Page(..)) 8 | where 9 | 10 | import Data.Text (Text) 11 | import Text.Blaze (Markup) 12 | 13 | -- | A page to be rendered in a layout. 14 | data Page = Page { 15 | pageTitle :: Text 16 | , pageBody :: Markup 17 | , pageName :: Text 18 | } 19 | -------------------------------------------------------------------------------- /src/Data/Text/ToText.hs: -------------------------------------------------------------------------------- 1 | module Data.Text.ToText where 2 | 3 | import Data.Text 4 | import qualified Data.Text.Lazy as L 5 | import Data.ByteString 6 | import Data.Text.Encoding 7 | import qualified Data.ByteString.Lazy as L 8 | 9 | class ToText a where 10 | toText :: a -> Text 11 | toLazyText :: a -> L.Text 12 | toLazyText = L.fromStrict . toText 13 | 14 | instance ToText ByteString where 15 | toText = decodeUtf8 16 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Channel model. 6 | 7 | module Hpaste.Model.Channel 8 | (getChannels) 9 | where 10 | 11 | import Hpaste.Types 12 | 13 | import Snap.App 14 | 15 | -- | Get the channels. 16 | getChannels :: Model c s [Channel] 17 | getChannels = 18 | queryNoParams ["SELECT *" 19 | ,"FROM channel"] 20 | -------------------------------------------------------------------------------- /src/Data/Time/Show.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Date/time showing functions. 6 | 7 | module Data.Time.Show 8 | (showDateTime) 9 | where 10 | 11 | import Data.Time (FormatTime,formatTime) 12 | import System.Locale (defaultTimeLocale) 13 | 14 | showDateTime :: FormatTime t => t -> String 15 | showDateTime time = formatTime defaultTimeLocale "%F %T %Z" time 16 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Script.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | JavaScript controller. 5 | 6 | module Hpaste.Controller.Script 7 | (handle) 8 | where 9 | 10 | import Hpaste.View.Script (script) 11 | 12 | import Snap.Core (modifyResponse,setContentType) 13 | import Snap.App 14 | 15 | handle :: Controller c s () 16 | handle = do 17 | modifyResponse $ setContentType "text/javascript" 18 | outputText $ script 19 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Stepeval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-orphans #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | -- | The stepeval types. 7 | 8 | module Hpaste.Types.Stepeval 9 | (StepevalPage(..)) 10 | where 11 | 12 | import Data.Text (Text) 13 | import Language.Haskell.HLint 14 | 15 | data StepevalPage = StepevalPage { 16 | sePaste :: Text 17 | , seHints :: [Suggestion] 18 | } 19 | -------------------------------------------------------------------------------- /src/Data/Either/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Data.Either.Extra where 5 | 6 | -- | When a value is Right, do something with it, monadically. 7 | whenRight :: Monad m => Either a b -> (b -> m c) -> m () 8 | whenRight (Right x) m = m x >> return () 9 | whenRight _ _ = return () 10 | 11 | -- | When a value is Left, do something with it, monadically. 12 | whenLeft :: Monad m => Either a b -> (a -> m c) -> m () 13 | whenLeft (Left x) m = m x >> return () 14 | whenLeft _ _ = return () 15 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Language.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Language model. 6 | 7 | module Hpaste.Model.Language 8 | (getLanguages) 9 | where 10 | 11 | import Hpaste.Types 12 | 13 | import Snap.App 14 | 15 | -- | Get the languages. 16 | getLanguages :: Model c s [Language] 17 | getLanguages = 18 | queryNoParams ["SELECT id,name,title" 19 | ,"FROM language" 20 | ,"WHERE visible" 21 | ,"ORDER BY ordinal ASC,title ASC"] 22 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Cache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | -- | HTML caching types. 4 | 5 | module Hpaste.Types.Cache 6 | (Key(..) 7 | ,Cache(..)) 8 | where 9 | 10 | import Control.Concurrent.MVar (MVar) 11 | import Data.Map (Map) 12 | import Data.Text.Lazy (Text) 13 | import Hpaste.Types.Newtypes 14 | 15 | data Key = 16 | Home 17 | | Paste PasteId 18 | | Revision PasteId 19 | | Activity 20 | deriving (Eq,Ord) 21 | 22 | data Cache = 23 | Cache { 24 | cacheMap :: MVar (Map Key Text) 25 | } 26 | -------------------------------------------------------------------------------- /amelie.conf.sample: -------------------------------------------------------------------------------- 1 | [POSTGRESQL] 2 | host = 127.0.0.1 3 | port = 5432 4 | user = hpaste 5 | pass = hpaste 6 | db = hpaste 7 | 8 | [ANNOUNCE] 9 | user = yourdomain 10 | pass = yourpass 11 | host = 127.0.0.1 12 | port = 6667 13 | 14 | [WEB] 15 | domain = yourdomain.org 16 | cache = /tmp/hpaste-cache 17 | 18 | [DEV] 19 | commits = https://github.com/chrisdone/hpaste/commits/master.atom 20 | repo_url = https://github.com/chrisdone/hpaste 21 | 22 | [IRC] 23 | log_dir = irc_logs 24 | 25 | [ADDRESSES] 26 | admin = email@yourdomain.com 27 | site_addy = noreply@yourdomain.org -------------------------------------------------------------------------------- /src/Hpaste/Controller/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Diff page controller. 6 | 7 | module Hpaste.Controller.Diff 8 | (handle) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.Controller.Paste (withPasteKey) 13 | import Hpaste.View.Diff (page) 14 | 15 | import Snap.App 16 | 17 | -- | Diff one paste with another. 18 | handle :: HPCtrl () 19 | handle = do 20 | withPasteKey "this" $ \this -> 21 | withPasteKey "that" $ \that -> 22 | output $ page this that 23 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | -- | The channel type. 4 | 5 | module Hpaste.Types.Channel 6 | (Channel(..)) 7 | where 8 | 9 | import Hpaste.Types.Newtypes 10 | import Control.Applicative 11 | import Data.Text (Text) 12 | import Database.PostgreSQL.Simple 13 | import Database.PostgreSQL.Simple.FromRow 14 | 15 | data Channel = Channel { 16 | channelId :: ChannelId 17 | ,channelName :: Text 18 | } deriving Show 19 | 20 | instance FromRow Channel where 21 | fromRow = Channel <$> field 22 | <*> field 23 | -------------------------------------------------------------------------------- /src/Data/String/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | 3 | -- | Instances that can be converted to a string. 4 | 5 | module Data.String.ToString where 6 | 7 | import Data.ByteString 8 | import qualified Data.ByteString.UTF8 as UTF8 (toString) 9 | 10 | class ToString string where 11 | toString :: string -> String 12 | 13 | instance ToString String where toString = id 14 | 15 | (+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String 16 | str1 +++ str2 = toString str1 ++ toString str2 17 | 18 | instance ToString ByteString where toString = UTF8.toString 19 | -------------------------------------------------------------------------------- /hpaste.conf.sample: -------------------------------------------------------------------------------- 1 | [POSTGRESQL] 2 | host = 127.0.0.1 3 | port = 5432 4 | user = hpaste 5 | pass = hpaste 6 | db = hpaste 7 | 8 | [ANNOUNCE] 9 | user = yourdomain 10 | pass = yourpass 11 | host = 127.0.0.1 12 | port = 6667 13 | 14 | [WEB] 15 | domain = yourdomain.org 16 | cache = /tmp/hpaste-cache 17 | 18 | [DEV] 19 | commits = https://github.com/chrisdone/hpaste/commits/master.atom 20 | repo_url = https://github.com/chrisdone/hpaste 21 | 22 | [IRC] 23 | log_dir = irc_logs 24 | 25 | [ADDRESSES] 26 | admin = email@yourdomain.com 27 | site_addy = noreply@yourdomain.org 28 | 29 | [ADMIN] 30 | key = myadminpass 31 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Announcer.hs: -------------------------------------------------------------------------------- 1 | module Hpaste.Types.Announcer where 2 | 3 | import Control.Concurrent 4 | import Data.Text 5 | 6 | -- | Announcer configuration. 7 | data AnnounceConfig = AnnounceConfig { 8 | announceUser :: String 9 | , announcePass :: String 10 | , announceHost :: String 11 | , announcePort :: Int 12 | } deriving (Show) 13 | 14 | -- | An announcer. 15 | data Announcer = Announcer 16 | { annChan :: Chan Announcement 17 | , annConfig :: AnnounceConfig 18 | } 19 | 20 | -- | An annoucement. 21 | data Announcement = Announcement 22 | { annFrom :: Text 23 | , annContent :: Text 24 | } 25 | -------------------------------------------------------------------------------- /src/Data/String/ToString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | -- | Instances that can be converted to a string. 5 | 6 | module Data.String.ToString where 7 | 8 | import Data.ByteString 9 | import qualified Data.ByteString.UTF8 as UTF8 (toString) 10 | 11 | class ToString string where 12 | toString :: string -> String 13 | 14 | instance ToString String where toString = id 15 | 16 | (+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String 17 | str1 +++ str2 = toString str1 ++ toString str2 18 | 19 | instance ToString ByteString where toString = UTF8.toString 20 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Language.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | 3 | -- | The language type. 4 | 5 | module Hpaste.Types.Language 6 | (Language(..)) 7 | where 8 | 9 | import Hpaste.Types.Newtypes 10 | import Control.Applicative 11 | import Data.Text (Text) 12 | import Database.PostgreSQL.Simple 13 | import Database.PostgreSQL.Simple.FromRow 14 | 15 | data Language = Language { 16 | languageId :: LanguageId 17 | ,languageName :: Text 18 | ,languageTitle :: Text 19 | } deriving Show 20 | 21 | instance FromRow Language where 22 | fromRow = Language <$> field 23 | <*> field 24 | <*> field 25 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Report.hs: -------------------------------------------------------------------------------- 1 | module Hpaste.Types.Report where 2 | 3 | import Hpaste.Types.Newtypes (PasteId) 4 | 5 | import Control.Applicative 6 | import Data.Text (Text) 7 | import Data.Time (UTCTime,zonedTimeToUTC) 8 | import Database.PostgreSQL.Simple 9 | import Database.PostgreSQL.Simple.FromRow 10 | 11 | data Report = Report { 12 | reportDate :: UTCTime 13 | ,reportPasteId :: PasteId 14 | ,reportComments :: Text 15 | } deriving Show 16 | 17 | instance FromRow Report where 18 | fromRow = Report <$> fmap zonedTimeToUTC field 19 | <*> field 20 | <*> field 21 | -------------------------------------------------------------------------------- /src/Hpaste/View/New.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Create new paste view. 6 | 7 | module Hpaste.View.New 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Prelude hiding ((++)) 16 | import Text.Blaze.Html5 as H hiding (map) 17 | 18 | -- | Render the create new paste page. 19 | page :: Html -> Html 20 | page form = 21 | layoutPage $ Page { 22 | pageTitle = "Create new paste" 23 | , pageBody = lightSection "Create new paste" form 24 | , pageName = "new" 25 | } 26 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Reported.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Reported page controller. 5 | 6 | module Hpaste.Controller.Reported 7 | (handle) 8 | where 9 | 10 | import Hpaste.Model.Report (getSomeReports,countReports) 11 | import Hpaste.Controller.Admin (withAuth) 12 | import Hpaste.Types 13 | import Hpaste.View.Reported (page) 14 | 15 | import Text.Blaze.Pagination 16 | import Data.Pagination 17 | import Snap.App 18 | 19 | -- | List the reported pastes. 20 | handle :: HPCtrl () 21 | handle = 22 | withAuth $ \key -> do 23 | pn <- getPagination "reported" 24 | total <- model countReports 25 | reports <- model $ getSomeReports (pnPn pn) 26 | output $ page pn reports key 27 | -------------------------------------------------------------------------------- /src/Hpaste/View/Edit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Edit paste view. 6 | 7 | module Hpaste.View.Edit 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Data.Monoid.Operator ((++)) 16 | import Prelude hiding ((++)) 17 | import Text.Blaze.Html5 as H hiding (map) 18 | import Data.Text.Lazy 19 | 20 | -- | Render the create edit paste page. 21 | page :: Paste -> Html -> Html 22 | page Paste{..} form = 23 | layoutPage $ Page { 24 | pageTitle = "Edit: " ++ pasteTitle 25 | , pageBody = lightSection ("Edit: " ++ fromStrict pasteTitle) form 26 | , pageName = "edit" 27 | } 28 | -------------------------------------------------------------------------------- /src/Hpaste/View/Annotate.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Annotate paste view. 6 | 7 | module Hpaste.View.Annotate 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Data.Monoid.Operator ((++)) 16 | import Prelude hiding ((++)) 17 | import Text.Blaze.Html5 as H hiding (map) 18 | import Data.Text.Lazy 19 | 20 | -- | Render the create annotate paste page. 21 | page :: Paste -> Html -> Html 22 | page Paste{..} form = 23 | layoutPage $ Page { 24 | pageTitle = "Annotate: " ++ pasteTitle 25 | , pageBody = lightSection ("Annotate: " ++ fromStrict pasteTitle) form 26 | , pageName = "annotate" 27 | } 28 | -------------------------------------------------------------------------------- /static/hpaste.el: -------------------------------------------------------------------------------- 1 | (defun lpaste-region () 2 | (interactive) 3 | (format "curl http://lpaste.net/new?%s" 4 | (mapconcat 'identity 5 | (mapcar (lambda (cons) 6 | (concat (url-hexify-string (car cons)) 7 | "=" 8 | (url-hexify-string (cdr cons)))) 9 | `(("title" . "Elis1p") 10 | ("author" . "chrisdone") 11 | ("language" . "haskell") 12 | ("channel" . "") 13 | ("paste" . "Code here'%@!") 14 | ("private" . "private") 15 | ("email" . ""))) 16 | "&"))) 17 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Activity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Activity page controller. 5 | 6 | module Hpaste.Controller.Activity 7 | (handle) 8 | where 9 | 10 | import Hpaste.Types 11 | import Hpaste.Controller.Cache (cache) 12 | import Hpaste.Model.Activity (getCommits) 13 | import Hpaste.Types.Cache as Key 14 | import Hpaste.View.Activity (page) 15 | 16 | import Control.Monad.Env (env) 17 | import Snap.App 18 | 19 | -- | Display commit history. 20 | handle :: HPCtrl () 21 | handle = do 22 | html <- cache Key.Activity $ do 23 | uri <- env $ configCommits . controllerStateConfig 24 | repourl <- env $ configRepoURL . controllerStateConfig 25 | commits <- model $ getCommits uri 26 | return $ Just $ page repourl commits 27 | maybe (return ()) outputText html 28 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Config.hs: -------------------------------------------------------------------------------- 1 | -- | Site-wide configuration. 2 | 3 | module Hpaste.Types.Config 4 | (Config(..) 5 | ,AnnounceConfig(..)) 6 | where 7 | 8 | import Database.PostgreSQL.Simple (ConnectInfo) 9 | import Network.Mail.Mime (Address) 10 | import Snap.App.Types 11 | 12 | import Hpaste.Types.Announcer 13 | 14 | -- | Site-wide configuration. 15 | data Config = Config { 16 | configAnnounce :: AnnounceConfig 17 | , configPostgres :: ConnectInfo 18 | , configDomain :: String 19 | , configCommits :: String 20 | , configRepoURL :: String 21 | , configIrcDir :: FilePath 22 | , configAdmin :: Address 23 | , configSiteAddy :: Address 24 | , configCacheDir :: FilePath 25 | , configKey :: String 26 | } 27 | 28 | instance AppConfig Config where 29 | getConfigDomain = configDomain 30 | 31 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Browse.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Browse page controller. 5 | 6 | module Hpaste.Controller.Browse 7 | (handle) 8 | where 9 | 10 | import Hpaste.Types 11 | import Hpaste.Model.Channel (getChannels) 12 | import Hpaste.Model.Language (getLanguages) 13 | import Hpaste.Model.Paste (getPaginatedPastes,countPublicPastes) 14 | import Hpaste.View.Browse (page) 15 | 16 | import Control.Monad.IO 17 | import Data.Time 18 | import Text.Blaze.Pagination 19 | import Snap.App 20 | 21 | -- | Browse all pastes. 22 | handle :: HPCtrl () 23 | handle = do 24 | pn <- getPagination "pastes" 25 | author <- getStringMaybe "author" 26 | (pn',pastes) <- model $ getPaginatedPastes author (pnPn pn) 27 | chans <- model getChannels 28 | langs <- model getLanguages 29 | now <- io getCurrentTime 30 | output $ page now pn { pnPn = pn' } chans langs pastes author 31 | -------------------------------------------------------------------------------- /src/Hpaste/View/Thanks.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Thanks view. 6 | 7 | module Hpaste.View.Thanks 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Data.String 16 | import Data.Text (Text) 17 | import Prelude hiding ((++)) 18 | import Text.Blaze.Html5 as H hiding (map) 19 | 20 | -- | Render the thanks5 page. 21 | page :: String -> String -> Html 22 | page title msg = 23 | layoutPage $ Page { 24 | pageTitle = fromString title 25 | , pageBody = thanks title msg 26 | , pageName = "thanks" 27 | } 28 | 29 | thanks :: String -> String -> Html 30 | thanks title msg = do 31 | darkSection (fromString title) $ do 32 | p $ toHtml msg 33 | p $ href ("/" :: Text) 34 | ("Go back home" :: Text) 35 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Raw.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Raw controller. 6 | 7 | module Hpaste.Controller.Raw 8 | (handle) 9 | where 10 | 11 | import Hpaste.Model.Paste (getPasteById) 12 | import Hpaste.Types 13 | 14 | import Control.Applicative 15 | import Data.ByteString.UTF8 (toString) 16 | import Data.Maybe 17 | import Data.Text.Lazy (fromStrict) 18 | import Prelude hiding ((++)) 19 | import Safe 20 | import Snap.App 21 | 22 | -- | Handle the paste page. 23 | handle :: HPCtrl () 24 | handle = do 25 | pid <- (>>= readMay) . fmap (toString) <$> getParam "id" 26 | case pid of 27 | Nothing -> goHome 28 | Just (pid :: Integer) -> do 29 | modifyResponse $ setContentType "text/plain; charset=UTF-8" 30 | paste <- model $ getPasteById (PasteId pid) 31 | maybe goHome (outputText . fromStrict . pastePaste) paste 32 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Irclogs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Irclogs page controller. 5 | 6 | module Hpaste.Controller.Irclogs 7 | (handle) 8 | where 9 | 10 | import Hpaste.Controller 11 | import Hpaste.Model.Irclogs 12 | import Hpaste.Types 13 | import Hpaste.View.Irclogs (page) 14 | 15 | import Data.String.ToString 16 | import Data.String 17 | import Snap.Types 18 | import Safe 19 | 20 | handle :: Controller () 21 | handle = do 22 | channel <- get "channel" 23 | date <- get "date" 24 | time <- get "timestamp" 25 | pasteid <- getMaybe "paste" 26 | logs <- getNarrowedLogs channel date time 27 | output $ page channel date time logs pasteid 28 | 29 | where get key = do 30 | value <- fmap (fmap toString) $ getParam (fromString key) 31 | case value of 32 | Nothing -> error $ "Missing parameter: " ++ key 33 | Just value -> return value 34 | getMaybe key = fmap ((>>= readMay) . fmap toString) $ getParam (fromString key) 35 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Home.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Home page controller. 5 | 6 | module Hpaste.Controller.Home 7 | (handle) 8 | where 9 | 10 | import Hpaste.Types 11 | import Hpaste.Controller.Cache (cacheIf) 12 | import Hpaste.Controller.Paste (pasteForm) 13 | import Hpaste.Model.Channel (getChannels) 14 | import Hpaste.Model.Language (getLanguages) 15 | import Hpaste.Model.Paste (getLatestPastes) 16 | import Hpaste.Types.Cache as Key 17 | import Hpaste.View.Home (page) 18 | 19 | import Data.Maybe 20 | import Snap.App 21 | 22 | -- | Handle the home page, display a simple list and paste form. 23 | handle :: Bool -> HPCtrl () 24 | handle spam = do 25 | html <- cacheIf (not spam) Key.Home $ do 26 | -- pastes <- model $ getLatestPastes Nothing 27 | chans <- model $ getChannels 28 | langs <- model $ getLanguages 29 | form <- pasteForm chans langs Nothing Nothing Nothing 30 | uri <- getMyURI 31 | return $ Just $ page uri chans langs [] form spam 32 | maybe (return ()) outputText html 33 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Newtypes.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | -- | Newtypes; foreign keys and such. 5 | 6 | module Hpaste.Types.Newtypes 7 | (PasteId(..) 8 | ,ChannelId(..) 9 | ,LanguageId(..) 10 | ,ReportId(..)) 11 | where 12 | 13 | import Database.PostgreSQL.Simple 14 | import Database.PostgreSQL.Simple.FromField 15 | import Database.PostgreSQL.Simple.ToField 16 | 17 | newtype PasteId = PasteId Integer 18 | deriving (Eq,FromField,ToField,Ord) 19 | 20 | instance Show PasteId where show (PasteId pid) = show pid 21 | 22 | newtype ReportId = ReportId Integer 23 | deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField) 24 | 25 | instance Show ReportId where show (ReportId pid) = show pid 26 | 27 | newtype ChannelId = ChannelId Integer 28 | deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField) 29 | 30 | instance Show ChannelId where show (ChannelId pid) = show pid 31 | 32 | newtype LanguageId = LanguageId Integer 33 | deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField) 34 | 35 | instance Show LanguageId where show (LanguageId pid) = show pid 36 | -------------------------------------------------------------------------------- /src/Hpaste/View/Activity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Activity page view. 6 | 7 | module Hpaste.View.Activity 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Control.Monad 16 | import Data.Text (Text) 17 | import Prelude hiding ((++)) 18 | import Text.Blaze.Html5 as H hiding (map) 19 | 20 | -- | Render the activity page. 21 | page :: String -> [Commit] -> Html 22 | page repo commits = 23 | layoutPage $ Page { 24 | pageTitle = "Development activity" 25 | , pageBody = activity repo commits 26 | , pageName = "activity" 27 | } 28 | 29 | -- | View the paginated pastes. 30 | activity :: String -> [Commit] -> Html 31 | activity repo commits = do 32 | darkSection "Development activity" $ do 33 | p $ do "Repository: " 34 | href repo repo 35 | forM_ commits $ \Commit{..} -> do 36 | lightSection commitTitle $ do 37 | p $ toHtml $ show commitDate 38 | p $ href commitLink ("Go to diff" :: Text) 39 | -------------------------------------------------------------------------------- /src/Hpaste/View/Hlint.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Show hlint suggestions. 6 | 7 | module Hpaste.View.Hlint 8 | (viewHints 9 | ,viewSuggestions) 10 | where 11 | 12 | import Hpaste.Types 13 | import Hpaste.View.Html 14 | 15 | import Data.List (intersperse) 16 | import Language.Haskell.HLint 17 | import Prelude hiding ((++)) 18 | import Text.Blaze.Html5 as H hiding (map) 19 | 20 | -- | Show hlint hints for a Haskell paste. 21 | viewHints :: [Hint] -> Html 22 | viewHints = mapM_ showHint where 23 | showHint hint = 24 | section $ 25 | pre ! aClass "hint" $ sequence_ $ intersperse br $ map toHtml lns 26 | where section = case hintType hint of 27 | Ignore -> \_ -> return () 28 | Warning -> warnNoTitleSection 29 | Error -> errorNoTitleSection 30 | lns = lines $ clean $ hintContent hint 31 | clean = dropWhile (==':') . dropWhile (/=':') 32 | 33 | viewSuggestions :: [Suggestion] -> Html 34 | viewSuggestions = viewHints . map toHint where 35 | toHint s = Hint (suggestionSeverity s) 36 | (show s) 37 | -------------------------------------------------------------------------------- /src/Network/URI/Params.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# OPTIONS -fno-warn-missing-signatures #-} 3 | module Network.URI.Params (updateUrlParam,updateUrlParams,uriParams,deleteQueryKey) where 4 | 5 | import Control.Arrow 6 | import Network.URI 7 | import Data.List 8 | import Data.Function 9 | import Network.CGI 10 | 11 | updateUrlParam :: String -> String -> URI -> URI 12 | updateUrlParam this value uri@(URI{uriQuery}) = 13 | uri { uriQuery = updated uriQuery } where 14 | updated = editQuery $ ((this,value):) . deleteBy ((==) `on` fst) (this,"") 15 | 16 | deleteQueryKey :: String -> URI -> URI 17 | deleteQueryKey key uri = 18 | uri { uriQuery = editQuery (filter ((/=key).fst)) (uriQuery uri) } 19 | 20 | editQuery :: ([(String,String)] -> [(String,String)]) -> String -> String 21 | editQuery f = ('?':) . formEncodeUrl . f . formDecode . dropWhile (=='?') 22 | 23 | formEncodeUrl = intercalate "&" . map keyval . map (esc *** esc) 24 | where keyval (key,val) = key ++ "=" ++ val 25 | esc = escapeURIString isAllowedInURI 26 | 27 | updateUrlParams :: [(String,String)] -> URI -> URI 28 | updateUrlParams = flip $ foldr $ uncurry updateUrlParam 29 | 30 | uriParams :: URI -> [(String,String)] 31 | uriParams = formDecode . dropWhile (=='?') . uriQuery 32 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Activity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Activity model. 5 | 6 | module Hpaste.Model.Activity 7 | (getCommits) 8 | where 9 | 10 | import Hpaste.Types 11 | 12 | import Control.Monad.IO (io) 13 | import Data.Maybe (mapMaybe) 14 | import Data.Text.Lazy (pack) 15 | import Data.Time 16 | import Network.Curl.Download 17 | import Snap.App.Types 18 | import System.Locale 19 | import Text.Feed.Query 20 | 21 | -- | Get commits of this project from a commit feed. 22 | getCommits :: String -> Model c s [Commit] 23 | getCommits uri = io $ do 24 | result <- openAsFeed uri 25 | case result of 26 | Left _ -> return [] 27 | Right feed -> return $ 28 | let items = getFeedItems feed 29 | in mapMaybe makeCommit items 30 | 31 | where makeCommit item = do 32 | title <- getItemTitle item 33 | datestr <- getItemDate item 34 | date <- parseDateString datestr 35 | link <- getItemLink item 36 | return $ Commit { 37 | commitTitle = pack $ title 38 | , commitContent = "" -- Getting content from atom does not work. 39 | , commitDate = date 40 | , commitLink = pack link 41 | } 42 | -- E.g. 2011-06-11T11:15:11-07:00 43 | parseDateString = parseTime defaultTimeLocale "%Y-%M-%dT%T%Z" 44 | -------------------------------------------------------------------------------- /src/Network/Email.hs: -------------------------------------------------------------------------------- 1 | module Network.SendEmail where 2 | 3 | -- | An email to be sent via SMTP. 4 | data Email = 5 | Email { emailSMTPHost :: String 6 | , emailEHLO :: String 7 | , emailFromName :: String 8 | , emailToName :: String 9 | , emailFromEmail :: String 10 | , emailToEmail :: String 11 | , emailSubject :: String 12 | , emailBody :: String 13 | } 14 | 15 | -- | Send an SMTP email. 16 | sendEmail :: (MonadIO m) => Email -> m () 17 | sendEmail Email{..} = 18 | io $ do 19 | addr <- lookupIP emailSMTPHost 20 | case addr of 21 | Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg] 22 | Nothing -> error "Unable to lookup the SMTP IP." 23 | where msg = SimpleMessage { 24 | from = [NameAddr (Just emailFromName) emailFromEmail] 25 | , to = [NameAddr (Just emailToName) emailToEmail] 26 | , subject = emailSubject 27 | , body = emailBody 28 | } 29 | -- | Look up the IP address for the SMTP server. 30 | lookupIP :: MonadIO m => String -> m (Maybe String) 31 | lookupIP domain = io $ do 32 | let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } 33 | addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp") 34 | return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs 35 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Admin.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | -- | Report controller. 7 | 8 | module Hpaste.Controller.Admin 9 | (withAuth) 10 | where 11 | 12 | import Hpaste.Controller.Cache (resetCache) 13 | import Hpaste.Model.Paste (getPasteById,deletePaste) 14 | import Hpaste.Model.Report 15 | import Hpaste.Types 16 | import Hpaste.Types.Cache as Key 17 | import Hpaste.View.Report 18 | import qualified Hpaste.View.Thanks as Thanks 19 | 20 | import Control.Applicative 21 | import Control.Monad.Reader 22 | import Data.ByteString.UTF8 (toString) 23 | import Data.Maybe 24 | import Data.Monoid.Operator ((++)) 25 | import Data.Text (unpack) 26 | import Prelude hiding ((++)) 27 | import Safe 28 | import Snap.App 29 | import Text.Blaze.Html5 as H hiding (output,map,body) 30 | import Text.Formlet 31 | 32 | -- | Do something with authority. 33 | withAuth :: (String -> HPCtrl ()) -> HPCtrl () 34 | withAuth m = do 35 | key <- fmap (fmap toString) $ getParam "key" 36 | realkey <- asks (configKey . controllerStateConfig) 37 | case key of 38 | Just k | k == realkey -> m k 39 | _ -> goHome 40 | -------------------------------------------------------------------------------- /src/Hpaste/View/Reported.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Reported page view. 6 | 7 | module Hpaste.View.Reported 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Text.Blaze.Pagination 16 | import Data.Monoid.Operator ((++)) 17 | import Data.Time.Show (showDateTime) 18 | import Prelude hiding ((++)) 19 | import Network.URI 20 | import Text.Blaze.Html5 as H hiding (map) 21 | import Snap.App.Types 22 | 23 | -- | Render the reported page. 24 | page :: PN -> [Report] -> String -> Html 25 | page pn rs key = 26 | layoutPage $ Page { 27 | pageTitle = "Reported pastes" 28 | , pageBody = reported pn rs key 29 | , pageName = "reported" 30 | } 31 | 32 | -- | View the paginated reports. 33 | reported :: PN -> [Report] -> String -> Html 34 | reported pn rs key = do 35 | darkSection "Reported pastes" $ do 36 | pagination pn 37 | table ! aClass "latest-pastes" $ do 38 | tr $ mapM_ (th . toHtml) $ words "Date Paste Delete Comments" 39 | reports rs 40 | pagination pn 41 | 42 | where reports = mapM_ $ \Report{..} -> tr $ do 43 | td $ toHtml $ showDateTime reportDate 44 | td $ href ("/" ++ show reportPasteId ++ "?show_private=true") $ show reportPasteId 45 | td $ href ("/delete?id=" ++ show reportPasteId ++ "&key=" ++ key) ("Delete"::String) 46 | td $ toHtml reportComments 47 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Rss.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | An RSS feed of recent pastes. 5 | 6 | module Hpaste.Controller.Rss where 7 | 8 | import Hpaste.Model.Paste 9 | import Hpaste.Model.Channel 10 | import Hpaste.Types 11 | 12 | import Control.Applicative 13 | import Control.Monad 14 | import Data.List 15 | import Data.Monoid 16 | import Data.String.ToString 17 | import qualified Data.Text as T 18 | import Data.Text.Encoding 19 | import Safe 20 | import Snap.App 21 | import Snap.App.RSS 22 | 23 | handle :: HPCtrl () 24 | handle = do 25 | cid <- getChannelId 26 | case cid of 27 | Nothing -> error "need a channel" 28 | Just cid' -> do 29 | pastes <- model $ getLatestPastes cid 30 | outputRSS "#haskell pastes" 31 | "http://lpaste.net/channel/haskell.rss" 32 | (map (\Paste{..} -> (pasteDate,pasteTitle,pastePaste, T.pack $ 33 | "http://lpaste.net/" ++ show pasteId)) 34 | pastes) 35 | 36 | getChannelId :: HPCtrl (Maybe ChannelId) 37 | getChannelId = do 38 | chname <- fmap (fmap decodeUtf8) $ getParam "channel" 39 | case chname of 40 | Nothing -> return Nothing 41 | Just chname -> do 42 | channels <- model $ getChannels 43 | case find ((==("#" <> chname)) . channelName) channels of 44 | Nothing -> return Nothing 45 | Just Channel{..} -> return (return channelId) 46 | -------------------------------------------------------------------------------- /src/Hpaste/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# OPTIONS -Wall -fno-warn-orphans #-} 5 | 6 | -- | All types. 7 | 8 | module Hpaste.Types 9 | (module Hpaste.Types.Paste 10 | ,module Hpaste.Types.Channel 11 | ,module Hpaste.Types.Language 12 | ,module Hpaste.Types.Page 13 | ,module Hpaste.Types.Newtypes 14 | ,module Hpaste.Types.Config 15 | ,module Hpaste.Types.Activity 16 | ,module Hpaste.Types.Stepeval 17 | ,module Hpaste.Types.Report 18 | ,HPState 19 | ,HPCtrl 20 | ,HPModel) 21 | where 22 | 23 | import Hpaste.Types.Paste 24 | import Hpaste.Types.Channel 25 | import Hpaste.Types.Language 26 | import Hpaste.Types.Page 27 | import Hpaste.Types.Newtypes 28 | import Hpaste.Types.Config 29 | import Hpaste.Types.Activity 30 | import Hpaste.Types.Stepeval 31 | import Hpaste.Types.Report 32 | import Hpaste.Types.Announcer (Announcer) 33 | 34 | import Control.Concurrent (Chan) 35 | import Control.Monad.Env 36 | import Control.Monad.IO 37 | import Control.Monad.Reader 38 | import Data.Text.Lazy (Text) 39 | import Snap.App.Types 40 | 41 | type HPState = Announcer 42 | type HPCtrl = Controller Config HPState 43 | type HPModel = Model Config HPState 44 | 45 | instance AppLiftModel Config HPState where 46 | liftModel action = do 47 | conn <- env controllerStateConn 48 | anns <- env controllerState 49 | conf <- env controllerStateConfig 50 | let state = ModelState conn anns conf 51 | io $ runReaderT (runModel action) state 52 | -------------------------------------------------------------------------------- /src/Network/SendEmail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | -- | Simple module for sending emails. 4 | 5 | module Network.SendEmail where 6 | 7 | import Control.Monad.IO 8 | import Control.Monad.Trans 9 | import Data.Maybe 10 | import Network.SMTP.Simple 11 | import Network.Socket 12 | 13 | -- | An email to be sent via SMTP. 14 | data Email = 15 | Email { emailSMTPHost :: String 16 | , emailEHLO :: String 17 | , emailFromName :: String 18 | , emailToName :: String 19 | , emailFromEmail :: String 20 | , emailToEmail :: String 21 | , emailSubject :: String 22 | , emailBody :: String 23 | } 24 | 25 | -- | Send an SMTP email. 26 | sendEmail :: (MonadIO m) => Email -> m () 27 | sendEmail Email{..} = 28 | io $ do 29 | addr <- lookupIP emailSMTPHost 30 | case addr of 31 | Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg] 32 | Nothing -> error "Unable to lookup the SMTP IP." 33 | where msg = SimpleMessage { 34 | from = [NameAddr (Just emailFromName) emailFromEmail] 35 | , to = [NameAddr (Just emailToName) emailToEmail] 36 | , subject = emailSubject 37 | , body = emailBody 38 | } 39 | -- | Look up the IP address for the SMTP server. 40 | lookupIP :: MonadIO m => String -> m (Maybe String) 41 | lookupIP domain = io $ do 42 | let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } 43 | addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp") 44 | return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs 45 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/New.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Create new paste controller. 5 | 6 | module Hpaste.Controller.New 7 | (handle,NewStyle(..)) 8 | where 9 | 10 | import Hpaste.Types 11 | import Hpaste.Controller.Paste (pasteForm,getPasteId) 12 | import Hpaste.Model.Channel (getChannels) 13 | import Hpaste.Model.Language (getLanguages) 14 | import Hpaste.Model.Paste (getPasteById) 15 | import Hpaste.View.Annotate as Annotate (page) 16 | import Hpaste.View.Edit as Edit (page) 17 | import Hpaste.View.New as New (page) 18 | 19 | import Control.Applicative 20 | import Data.Text.Encoding (decodeUtf8) 21 | import Snap.App 22 | 23 | data NewStyle = NewPaste | AnnotatePaste | EditPaste 24 | deriving Eq 25 | 26 | -- | Make a new paste. 27 | handle :: NewStyle -> HPCtrl () 28 | handle style = do 29 | chans <- model $ getChannels 30 | langs <- model $ getLanguages 31 | defChan <- fmap decodeUtf8 <$> getParam "channel" 32 | pid <- if style == NewPaste then return Nothing else getPasteId 33 | case pid of 34 | Just pid -> do 35 | paste <- model $ getPasteById pid 36 | let apaste | style == AnnotatePaste = paste 37 | | otherwise = Nothing 38 | let epaste | style == EditPaste = paste 39 | | otherwise = Nothing 40 | form <- pasteForm chans langs defChan apaste epaste 41 | justOrGoHome paste $ \paste -> do 42 | case style of 43 | AnnotatePaste -> output $ Annotate.page paste form 44 | EditPaste -> output $ Edit.page paste form 45 | _ -> goHome 46 | Nothing -> do 47 | form <- pasteForm chans langs defChan Nothing Nothing 48 | output $ New.page form 49 | -------------------------------------------------------------------------------- /static/hs/stepeval-prelude.hs: -------------------------------------------------------------------------------- 1 | module Prelude where 2 | 3 | -- Arithmetic operations and some other primitives are builtin 4 | -- Type signatures are entirely useless here. 5 | -- Guards on the rhs of function equations are not supported, but in case 6 | -- expressions they are. 7 | 8 | -- combinators 9 | id x = x 10 | 11 | const x _ = x 12 | 13 | f $ x = f x 14 | -- infixr 0 $ 15 | 16 | flip f x y = f y x 17 | 18 | (f . g) x = f (g x) 19 | -- infixr 9 . 20 | 21 | fix f = let x = f x in x 22 | 23 | -- booleans 24 | not True = False 25 | not False = True 26 | 27 | True || _ = True 28 | False || b = b 29 | -- infixr 2 || 30 | 31 | False && _ = False 32 | True && b = b 33 | -- infixr 3 && 34 | 35 | -- tuples 36 | fst (x, _) = x 37 | snd (_, x) = x 38 | 39 | curry f x y = f (x, y) 40 | uncurry f (x, y) = f x y 41 | 42 | -- lists 43 | foldr _ z [] = z 44 | foldr f z (x:xs) = x `f` foldr f z xs 45 | 46 | foldl _ acc [] = acc 47 | foldl f acc (x:xs) = foldl f (f acc x) xs 48 | -- foldl f z xs = foldr (\x r z -> r (f z x)) id xs z 49 | 50 | null [] = True 51 | null _ = False 52 | 53 | map f [] = [] 54 | map f (x:xs) = f x : map f xs 55 | 56 | head (x:_) = x 57 | tail (_:xs) = xs 58 | 59 | [] ++ ys = ys 60 | (x:xs) ++ ys = x : (xs ++ ys) 61 | -- infixr 5 ++ 62 | 63 | take n xs = if n <= 0 then [] 64 | else case xs of 65 | [] -> [] 66 | y:ys -> y : take (n - 1) ys 67 | 68 | repeat x = let xs = x : xs in xs 69 | 70 | drop n xs = if n <= 0 || null xs 71 | then xs 72 | else drop (n - 1) (tail xs) 73 | 74 | length [] = 0 75 | length (x:xs) = 1 + length xs 76 | 77 | scanl f z [] = [z] 78 | scanl f z (x:xs) = z : scanl f (f z x) xs 79 | 80 | reverse = foldl (flip (:)) [] 81 | 82 | zipWith _ [] _ = [] 83 | zipWith _ _ [] = [] 84 | zipWith (*) (x:xs) (y:ys) = x * y : zipWith (*) xs ys 85 | 86 | iterate f x = x : iterate f (f x) 87 | -------------------------------------------------------------------------------- /src/Hpaste/Config.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-} 2 | 3 | -- | Load the configuration file. 4 | 5 | module Hpaste.Config 6 | (getConfig) 7 | where 8 | 9 | import Hpaste.Types.Config 10 | import Hpaste.Model.Announcer 11 | 12 | import Data.ConfigFile 13 | import Database.PostgreSQL.Simple (ConnectInfo(..)) 14 | import qualified Data.Text as T 15 | import Network.Mail.Mime 16 | 17 | getConfig :: FilePath -> IO Config 18 | getConfig conf = do 19 | contents <- readFile conf 20 | let config = do 21 | c <- readstring emptyCP contents 22 | [user,pass,host,port] 23 | <- mapM (get c "ANNOUNCE") 24 | ["user","pass","host","port"] 25 | [pghost,pgport,pguser,pgpass,pgdb] 26 | <- mapM (get c "POSTGRESQL") 27 | ["host","port","user","pass","db"] 28 | [domain,cache] 29 | <- mapM (get c "WEB") 30 | ["domain","cache"] 31 | [commits,url] 32 | <- mapM (get c "DEV") 33 | ["commits","repo_url"] 34 | [ircDir] 35 | <- mapM (get c "IRC") 36 | ["log_dir"] 37 | [admin,siteaddy] 38 | <- mapM (get c "ADDRESSES") 39 | ["admin","site_addy"] 40 | [key] <- mapM (get c "ADMIN") ["key"] 41 | 42 | return Config { 43 | configAnnounce = AnnounceConfig user pass host (read port) 44 | , configPostgres = ConnectInfo pghost (read pgport) pguser pgpass pgdb 45 | , configDomain = domain 46 | , configCommits = commits 47 | , configRepoURL = url 48 | , configIrcDir = ircDir 49 | , configAdmin = Address Nothing (T.pack admin) 50 | , configSiteAddy = Address Nothing (T.pack siteaddy) 51 | , configCacheDir = cache 52 | , configKey = key 53 | } 54 | case config of 55 | Left cperr -> error $ show cperr 56 | Right config -> return config 57 | -------------------------------------------------------------------------------- /src/Data/Time/Relative.hs: -------------------------------------------------------------------------------- 1 | -- | Display times as a relative duration. E.g. x days ago. 2 | 3 | module Data.Time.Relative where 4 | 5 | import Data.List 6 | import Data.Time 7 | import Text.Printf 8 | 9 | -- | Display a time span as one time relative to another. 10 | relativeZoned :: ZonedTime -- ^ The later time span. 11 | -> ZonedTime -- ^ The earlier time span. 12 | -> Bool -- ^ Display 'in/ago'? 13 | -> String -- ^ Example: '3 seconds ago', 'in three days'. 14 | relativeZoned t1 t2 fix = 15 | relative (zonedTimeToUTC t1) (zonedTimeToUTC t2) fix 16 | 17 | -- | Display a time span as one time relative to another. 18 | relative :: UTCTime -- ^ The later time span. 19 | -> UTCTime -- ^ The earlier time span. 20 | -> Bool -- ^ Display 'in/ago'? 21 | -> String -- ^ Example: '3 seconds ago', 'in three days'. 22 | relative t1 t2 fix = maybe "unknown" format $ find (\(s,_,_) -> abs span>=s) $ reverse ranges where 23 | minute = 60; hour = minute * 60; day = hour * 24; 24 | week = day * 7; month = day * 30; year = month * 12 25 | format range = 26 | (if fix && span>0 then "in " else "") 27 | ++ case range of 28 | (_,str,0) -> str 29 | (_,str,base) -> printf str (abs $ round (span / base) :: Integer) 30 | ++ (if fix && span<0 then " ago" else "") 31 | span = t1 `diffUTCTime` t2 32 | ranges = [(0,"%d seconds",1) 33 | ,(minute,"a minute",0) 34 | ,(minute*2,"%d minutes",minute) 35 | ,(minute*30,"half an hour",0) 36 | ,(minute*31,"%d minutes",minute) 37 | ,(hour,"an hour",0) 38 | ,(hour*2,"%d hours",hour) 39 | ,(hour*3,"a few hours",0) 40 | ,(hour*4,"%d hours",hour) 41 | ,(day,"a day",0) 42 | ,(day*2,"%d days",day) 43 | ,(week,"a week",0) 44 | ,(week*2,"%d weeks",week) 45 | ,(month,"a month",0) 46 | ,(month*2,"%d months",month) 47 | ,(year,"a year",0) 48 | ,(year*2,"%d years",year) 49 | ] 50 | -------------------------------------------------------------------------------- /src/Hpaste/View/Irclogs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Irclogs page view. 6 | 7 | module Hpaste.View.Irclogs 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | 15 | import Control.Monad 16 | import Data.Char 17 | import Data.Maybe 18 | import Data.Monoid.Operator ((++)) 19 | import Data.String 20 | import Data.Text (Text) 21 | import qualified Data.Text as T 22 | import Prelude hiding ((++)) 23 | import Text.Blaze.Extra 24 | import Text.Blaze.Html5 as H hiding (map) 25 | import qualified Text.Blaze.Html5.Attributes as A 26 | 27 | -- | Render the irclogs page. 28 | page :: String -> String -> String -> Either String [Text] -> Maybe Integer -> Html 29 | page channel date time entries pid = 30 | layoutPage $ Page { 31 | pageTitle = "Development irclogs" 32 | , pageBody = irclogs pid channel entries 33 | , pageName = "irclogs" 34 | } 35 | 36 | -- | View the paginated pastes. 37 | irclogs :: Maybe Integer -> String -> Either String [Text] -> Html 38 | irclogs pid channel entries = do 39 | darkSection "IRC logs" $ do 40 | p $ do "Channel: #"; toHtml channel 41 | lightSection (fromString ("#" ++ channel)) $ do 42 | case entries of 43 | Left error -> do "Unable to get logs for this channel and date: " 44 | toHtml error 45 | Right entries -> 46 | ul !. "amelie-irc-entries" $ 47 | forM_ entries $ \entry -> do 48 | let date = toValue $ parseDate entry 49 | url = "http://hpaste.org/" ++ maybe "0" (T.pack . show) pid 50 | currentline | T.isSuffixOf url entry = "current" 51 | | otherwise = "" 52 | li !. (toValue (currentline :: Text)) $ do 53 | a ! A.name date ! A.id date $ return () 54 | toHtml entry 55 | 56 | where parseDate = T.replace ":" "-" . T.takeWhile (not.isSpace) 57 | -------------------------------------------------------------------------------- /src/Hpaste/View/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Diff page view. 6 | 7 | module Hpaste.View.Diff 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | import Hpaste.View.Paste (pasteLink) 15 | 16 | import Control.Monad 17 | import Data.Algorithm.Diff 18 | import Data.Monoid.Operator ((++)) 19 | import qualified Data.Text as T 20 | import Data.Text.Lazy (pack) 21 | import Prelude hiding ((++)) 22 | import Text.Blaze.Html5 as H hiding (map) 23 | 24 | -- | Render the diff page. 25 | page :: Paste -> Paste -> Html 26 | page this that = 27 | layoutPage $ Page { 28 | pageTitle = "Diff two pastes" 29 | , pageBody = diffBody this that 30 | , pageName = "diff" 31 | } 32 | 33 | -- | View the diff between the two pastes. 34 | diffBody :: Paste -> Paste -> Html 35 | diffBody this that = do 36 | darkSection ("Diff: " ++ pid1 ++ " / " ++ pid2) $ do 37 | pasteMention this pid1 38 | pasteMention that pid2 39 | lightNoTitleSection $ do 40 | viewDiff this that 41 | 42 | where pasteMention paste pid = p $ do 43 | pasteLink paste pid 44 | ": " 45 | toHtml $ pasteTitle paste 46 | pid1 = pack (show (pasteId this)) 47 | pid2 = pack (show (pasteId that)) 48 | 49 | -- | View the diff between the two pastes. 50 | viewDiff :: Paste -> Paste -> Html 51 | viewDiff this that = do 52 | H.table ! aClass "code" $ 53 | td $ 54 | pre $ do 55 | forM_ groups $ \(indicator,lines) -> do 56 | let (ind,prefix) = 57 | case indicator of 58 | B -> ("diff-both"," ") 59 | F -> ("diff-first","- ") 60 | S -> ("diff-second","+ ") 61 | lins = map (prefix++) lines 62 | H.div ! aClass ind $ toHtml $ T.unlines $ lins 63 | 64 | where groups = getGroupedDiff lines1 lines2 65 | lines1 = T.lines (pastePaste this) 66 | lines2 = T.lines (pastePaste that) 67 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Main entry point. 5 | 6 | module Main (main) where 7 | 8 | import Hpaste.Config 9 | import Hpaste.Controller.Activity as Activity 10 | import Hpaste.Controller.Browse as Browse 11 | import Hpaste.Controller.Diff as Diff 12 | import Hpaste.Controller.Home as Home 13 | import Hpaste.Controller.New as New 14 | import Hpaste.Controller.Paste as Paste 15 | import Hpaste.Controller.Raw as Raw 16 | import Hpaste.Controller.Report as Report 17 | import Hpaste.Controller.Reported as Reported 18 | import Hpaste.Controller.Rss as Rss 19 | import Hpaste.Controller.Script as Script 20 | import Hpaste.Model.Announcer (newAnnouncer) 21 | import Hpaste.Types 22 | import Hpaste.Types.Announcer 23 | 24 | import Control.Concurrent.Chan (Chan) 25 | import Data.Text.Lazy (Text) 26 | import System.Environment 27 | import Snap.App 28 | import Snap.Http.Server hiding (Config) 29 | import Snap.Util.FileServe 30 | 31 | 32 | -- | Main entry point. 33 | main :: IO () 34 | main = do 35 | cpath:_ <- getArgs 36 | config <- getConfig cpath 37 | announces <- newAnnouncer (configAnnounce config) 38 | pool <- newPool (configPostgres config) 39 | setUnicodeLocale "en_US" 40 | httpServe server (serve config pool announces) 41 | where server = setPort 10000 defaultConfig 42 | 43 | -- | Serve the controllers. 44 | serve :: Config -> Pool -> Announcer -> Snap () 45 | serve config pool ans = route routes where 46 | routes = [("/css/",serveDirectory "static/css") 47 | ,("/js/amelie.hs.js",run Script.handle) 48 | ,("/js/",serveDirectory "static/js") 49 | ,("/hs/",serveDirectory "static/hs") 50 | ,("",run (Home.handle False)) 51 | ,("/spam",run (Home.handle True)) 52 | ,("/:id",run (Paste.handle False)) 53 | ,("/raw/:id",run Raw.handle) 54 | ,("/revision/:id",run (Paste.handle True)) 55 | ,("/report/:id",run Report.handle) 56 | ,("/reported",run Reported.handle) 57 | ,("/new",run (New.handle New.NewPaste)) 58 | ,("/annotate/:id",run (New.handle New.AnnotatePaste)) 59 | ,("/edit/:id",run (New.handle New.EditPaste)) 60 | ,("/new/:channel",run (New.handle New.NewPaste)) 61 | ,("/browse",run Browse.handle) 62 | ,("/activity",run Activity.handle) 63 | ,("/diff/:this/:that",run Diff.handle) 64 | ,("/delete",run Report.handleDelete) 65 | ,("/channel/:channel/rss",run Rss.handle) 66 | ] 67 | run = runHandler ans config pool 68 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Announcer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | -- | IRC announcer. 7 | 8 | module Hpaste.Model.Announcer 9 | (newAnnouncer 10 | ,announce 11 | ) 12 | where 13 | 14 | import Hpaste.Types.Announcer 15 | import Control.Monad.Fix 16 | import Control.Concurrent 17 | import qualified Control.Exception as E 18 | import Control.Monad 19 | import Control.Monad.Env (env) 20 | import Control.Monad.IO (io) 21 | import qualified Data.ByteString as B 22 | import Data.Monoid.Operator ((++)) 23 | import Data.Char 24 | import Data.Text (Text,pack,unpack) 25 | import qualified Data.Text as T 26 | import Data.Text.Encoding 27 | import Data.Time 28 | import qualified Data.Text.IO as T 29 | import Network 30 | import Prelude hiding ((++)) 31 | import Snap.App.Types 32 | import System.IO 33 | 34 | -- | Start a thread and return a channel to it. 35 | newAnnouncer :: AnnounceConfig -> IO Announcer 36 | newAnnouncer config = do 37 | putStrLn "Connecting..." 38 | ans <- newChan 39 | let self = Announcer { annChan = ans, annConfig = config } 40 | _ <- forkIO $ announcer self (const (return ())) 41 | return self 42 | 43 | -- | Run the announcer bot. 44 | announcer :: Announcer -> (Handle -> IO ()) -> IO () 45 | announcer self@Announcer{annConfig=config,annChan=ans} cont = do 46 | announcements <- getChanContents ans 47 | forM_ announcements $ \ann -> 48 | E.catch (sendIfNickExists config ann) 49 | (\(e::IOError) -> return ()) 50 | 51 | sendIfNickExists AnnounceConfig{..} (Announcement origin line) = do 52 | handle <- connectTo announceHost (PortNumber $ fromIntegral announcePort) 53 | hSetBuffering handle LineBuffering 54 | let send = B.hPutStrLn handle . encodeUtf8 55 | send $ "PASS " ++ pack announcePass 56 | send $ "USER " ++ pack announceUser ++ " * * *" 57 | send $ "NICK " ++ pack announceUser 58 | send $ "WHOIS :" ++ origin 59 | fix $ \loop -> do 60 | incoming <- T.hGetLine handle 61 | case T.takeWhile isDigit (T.drop 1 (T.dropWhile (/=' ') incoming)) of 62 | "311" -> send line 63 | "401" -> return () 64 | _ -> loop 65 | 66 | -- | Announce something to the IRC. 67 | announce :: Announcer -> Text -> Text -> Text -> IO () 68 | announce Announcer{annChan=chan} nick channel line = do 69 | io $ writeChan chan $ Announcement nick ("PRIVMSG " ++ channel ++ " :" ++ line) 70 | -------------------------------------------------------------------------------- /src/Hpaste/View/Report.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Report view. 6 | 7 | module Hpaste.View.Report 8 | (page,reportFormlet) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Highlight 13 | import Hpaste.View.Html 14 | import Hpaste.View.Layout 15 | 16 | import Data.Monoid.Operator ((++)) 17 | import Data.Text (Text) 18 | import Prelude hiding ((++)) 19 | import Text.Blaze.Html5 as H hiding (map) 20 | import qualified Text.Blaze.Html5.Attributes as A 21 | import Text.Formlet 22 | 23 | -- | Render the page page. 24 | page :: Html -> Paste -> Html 25 | page form paste = 26 | layoutPage $ Page { 27 | pageTitle = "Report a paste" 28 | , pageBody = do reporting form; viewPaste paste 29 | , pageName = "paste" 30 | } 31 | 32 | reporting :: Html -> Html 33 | reporting form = do 34 | lightSection "Report a paste" $ do 35 | p $ do "Please state any comments regarding the paste:" 36 | H.form ! A.method "post" $ do 37 | form 38 | 39 | -- | View a paste's details and content. 40 | viewPaste :: Paste -> Html 41 | viewPaste Paste{..} = do 42 | pasteDetails pasteTitle 43 | pasteContent pastePaste 44 | 45 | -- | List the details of the page in a dark section. 46 | pasteDetails :: Text -> Html 47 | pasteDetails title = 48 | darkNoTitleSection $ do 49 | pasteNav 50 | h2 $ toHtml title 51 | ul ! aClass "paste-specs" $ do 52 | detail "Language" $ "Haskell" 53 | detail "Raw" $ href ("/stepeval/raw" :: Text) 54 | ("View raw link" :: Text) 55 | clear 56 | 57 | where detail title content = do 58 | li $ do strong (title ++ ":"); content 59 | 60 | -- | Individual paste navigation. 61 | pasteNav :: Html 62 | pasteNav = 63 | H.div ! aClass "paste-nav" $ do 64 | href ("https://github.com/benmachine/stepeval" :: Text) 65 | ("Go to stepeval project" :: Text) 66 | 67 | -- | Show the paste content with highlighting. 68 | pasteContent :: Text -> Html 69 | pasteContent paste = 70 | lightNoTitleSection $ 71 | highlightHaskell paste 72 | 73 | -- | A formlet for report submission / annotating. 74 | reportFormlet :: ReportFormlet -> (Formlet Text,Html) 75 | reportFormlet ReportFormlet{..} = 76 | let frm = form $ do 77 | formletHtml reportSubmit rfParams 78 | submitInput "submit" "Submit" 79 | in (reportSubmit,frm) 80 | 81 | reportSubmit :: Formlet Text 82 | reportSubmit = req (textInput "report" "Comments" Nothing) 83 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Report.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | -- | Report model. 8 | 9 | module Hpaste.Model.Report 10 | (getSomeReports,createReport,countReports) 11 | where 12 | 13 | import Hpaste.Types 14 | import Hpaste.Controller.Cache 15 | import Hpaste.Types.Cache as Key 16 | 17 | import Control.Monad 18 | 19 | import Control.Monad.Env 20 | import Control.Monad.IO 21 | import Data.Pagination 22 | import Data.Maybe 23 | import Data.Monoid.Operator ((++)) 24 | import qualified Data.Text as T 25 | import qualified Data.Text.Lazy as LT 26 | import Network.Mail.Mime 27 | import Prelude hiding ((++)) 28 | import Snap.App 29 | 30 | -- | Get some paginated reports. 31 | getSomeReports :: Pagination -> Model c s [Report] 32 | getSomeReports Pagination{..} = 33 | queryNoParams ["SELECT created,paste,comments" 34 | ,"FROM report" 35 | ,"ORDER BY id DESC" 36 | ,"OFFSET " ++ show (max 0 (pnCurrentPage - 1) * pnPerPage) 37 | ,"LIMIT " ++ show pnPerPage] 38 | 39 | -- | Count reports. 40 | countReports :: Model c s Integer 41 | countReports = do 42 | rows <- singleNoParams ["SELECT COUNT(*)" 43 | ,"FROM report"] 44 | return $ fromMaybe 0 rows 45 | 46 | -- | Create a new report. 47 | createReport :: ReportSubmit -> Model Config s (Maybe ReportId) 48 | createReport rs@ReportSubmit{..} = do 49 | res <- single ["INSERT INTO report" 50 | ,"(paste,comments)" 51 | ,"VALUES" 52 | ,"(?,?)" 53 | ,"returning id"] 54 | (rsPaste,rsComments) 55 | _ <- exec ["UPDATE paste" 56 | ,"SET public = false" 57 | ,"WHERE id = ?"] 58 | (Only rsPaste) 59 | let reset pid = do 60 | resetCacheModel (Key.Paste pid) 61 | resetCacheModel (Key.Revision pid) 62 | reset rsPaste 63 | sendReport rs 64 | return res 65 | 66 | sendReport :: ReportSubmit -> Model Config s () 67 | sendReport ReportSubmit{..} = do 68 | conf <- env modelStateConfig 69 | m <- io $ simpleMail (configAdmin conf) 70 | (configSiteAddy conf) 71 | (T.pack ("Paste reported: #" ++ show rsPaste)) 72 | (LT.pack body) 73 | (LT.pack body) 74 | [] 75 | io $ renderSendMail m 76 | 77 | where body = 78 | "Paste " ++ show rsPaste ++ "\n\n" ++ 79 | "http://hpaste.org/" ++ show rsPaste ++ "?show_private=true" ++ 80 | "\n\n" ++ 81 | rsComments 82 | -------------------------------------------------------------------------------- /src/Hpaste/View/Home.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Home page view. 6 | 7 | module Hpaste.View.Home 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | import Hpaste.View.Paste (pasteLink) 15 | 16 | import Control.Monad 17 | import Data.Text (Text) 18 | import Data.Time.Show (showDateTime) 19 | import Prelude hiding ((++)) 20 | import Text.Blaze.Html5 as H hiding (map) 21 | import qualified Data.Text as T 22 | import Text.Blaze.Extra 23 | import Network.URI.Params 24 | import Network.URI 25 | 26 | -- | Render the home page. 27 | page :: URI -> [Channel] -> [Language] -> [Paste] -> Html -> Bool -> Html 28 | page uri chans langs ps form spam = 29 | layoutPage $ Page { 30 | pageTitle = "Recent pastes" 31 | , pageBody = content uri chans langs ps form spam 32 | , pageName = "home" 33 | } 34 | 35 | -- | Render the home page body. 36 | content :: URI -> [Channel] -> [Language] -> [Paste] -> Html -> Bool -> Html 37 | content uri chans langs ps form spam = do 38 | when spam $ p $ strong $ do "Your submission was identified as being probably spam and was ignored. " 39 | "Try reducing links and making your paste look less spammy. " 40 | "If the problem persists, try contacting support and we will adjust the spam filters." 41 | createNew form 42 | -- latest uri chans langs ps 43 | 44 | -- | Create a new paste section. 45 | createNew :: Html -> Html 46 | createNew = lightSection "Create new paste" 47 | 48 | -- | View the latest pastes. 49 | latest :: URI -> [Channel] -> [Language] -> [Paste] -> Html 50 | latest uri channels languages ps = do 51 | darkSection "Latest pastes" $ do 52 | table ! aClass "latest-pastes" $ do 53 | tr $ mapM_ (th . toHtml) $ words "Title Author When Language Channel" 54 | pastes ps 55 | p ! aClass "browse-link" $ browse 56 | 57 | where pastes = mapM_ $ \paste@Paste{..} -> tr $ do 58 | td $ pasteLink paste pasteTitle 59 | td $ do 60 | let author = T.unpack pasteAuthor 61 | if True -- validNick author 62 | then a ! hrefURI (authorUri author) $ toHtml pasteAuthor 63 | else toHtml pasteAuthor 64 | td $ toHtml $ showDateTime $ pasteDate 65 | td $ showLanguage languages pasteLanguage 66 | td $ showChannel Nothing channels pasteChannel 67 | authorUri author = updateUrlParam "author" author 68 | $ updateUrlParam "page" "0" 69 | $ uri { uriPath = "/browse" } 70 | 71 | -- | Browse link. 72 | browse :: Html 73 | browse = href ("/browse" :: Text) ("Browse all pastes" :: Text) 74 | -------------------------------------------------------------------------------- /src/Hpaste/View/Script.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | -- | Page script. 7 | 8 | module Hpaste.View.Script 9 | (script) 10 | where 11 | 12 | import Data.Text.Lazy (Text,pack) 13 | import HJScript 14 | import HJScript.Objects.JQuery hiding (prepend,append) 15 | import HJScript.Objects.JQuery.Extra 16 | import Prelude hiding ((++),max) 17 | 18 | -- | All scripts on the site. Not much to do. 19 | script :: Text 20 | script = pack $ show $ snd $ evalHJScript $ do 21 | ready $ do 22 | -- resizePage 23 | toggleHints 24 | togglePaste 25 | 26 | -- | Resize the width of the page to match content width. 27 | resizePage :: HJScript () 28 | resizePage = do 29 | max <- varWith (int 0) 30 | each (do max .=. (mathMax 500 31 | (mathMax (getWidth this' + 50) (val max))) 32 | return true) 33 | (j ".amelie-code") 34 | each (do setWidth (mathMax (val max) 500) 35 | (j ".amelie-wrap") 36 | return true) 37 | (j ".amelie-code") 38 | each (do setWidth (mathMax (getWidth this') 500) 39 | (j ".amelie-wrap") 40 | return true) 41 | (j ".amelie-latest-pastes") 42 | 43 | -- | Collapse/expand hints when toggled. 44 | toggleHints :: HJScript () 45 | toggleHints = do 46 | each (do this <- varWith this' 47 | collapse this 48 | css' "cursor" "pointer" (parent this) 49 | toggle (expand this) 50 | (collapse this) 51 | (parent this) 52 | return true) 53 | (j ".amelie-hint") 54 | 55 | where collapse o = do 56 | css "height" "1em" o 57 | css "overflow" "hidden" o 58 | return false 59 | expand o = do 60 | css "height" "auto" o 61 | return false 62 | 63 | -- | Toggle paste details. 64 | togglePaste :: HJScript () 65 | togglePaste = do 66 | each (do btn <- varWith (j "Expand") 67 | this <- varWith this' 68 | prepend (string " - ") this 69 | prepend (val btn) this 70 | details <- varWith (siblings ".amelie-paste-specs" this) 71 | display btn "none" details 72 | toggle (display btn "block" details) 73 | (display btn "none" details) 74 | btn 75 | return true) 76 | (j ".amelie-paste-nav") 77 | 78 | where display btn prop o = do 79 | css "display" prop o 80 | setText (string caption) btn 81 | return false 82 | where caption = if prop == "block" then "Collapse" else "Expand" 83 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Report.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | -- | Report controller. 7 | 8 | module Hpaste.Controller.Report 9 | (handle 10 | ,handleDelete) 11 | where 12 | 13 | import Hpaste.Controller.Cache (resetCache) 14 | import Hpaste.Controller.Admin (withAuth) 15 | import Hpaste.Model.Paste (getPasteById,deletePaste) 16 | import Hpaste.Model.Report 17 | import Hpaste.Types 18 | import Hpaste.Types.Cache as Key 19 | import Hpaste.View.Report 20 | import qualified Hpaste.View.Thanks as Thanks 21 | 22 | import Control.Applicative 23 | import Control.Monad.Reader 24 | import Data.ByteString.UTF8 (toString) 25 | import Data.String 26 | import Data.Maybe 27 | import Data.Monoid.Operator ((++)) 28 | import Data.Text (unpack) 29 | import Prelude hiding ((++)) 30 | import Safe 31 | import Snap.App 32 | import Text.Blaze.Html5 as H hiding (output,map,body) 33 | import Text.Formlet 34 | 35 | -- | Handle the report/delete page. 36 | handle :: HPCtrl () 37 | handle = do 38 | pid <- (>>= readMay) . fmap (toString) <$> getParam "id" 39 | case pid of 40 | Nothing -> goHome 41 | Just (pid :: Integer) -> do 42 | paste <- model $ getPasteById (PasteId pid) 43 | (frm,val) <- exprForm 44 | case val of 45 | Just comment -> do 46 | _ <- model $ createReport ReportSubmit { rsPaste = PasteId pid 47 | , rsComments = comment } 48 | resetCache Key.Home 49 | output $ Thanks.page "Reported" $ 50 | "Thanks, your comments have " ++ 51 | "been reported to the administrator." 52 | Nothing -> maybe goHome (output . page frm) paste 53 | 54 | -- | Report form. 55 | exprForm :: HPCtrl (Html,Maybe String) 56 | exprForm = do 57 | params <- getParams 58 | submitted <- isJust <$> getParam "submit" 59 | let formlet = ReportFormlet { 60 | rfSubmitted = submitted 61 | , rfParams = params 62 | } 63 | (getValue,_) = reportFormlet formlet 64 | value = formletValue getValue params 65 | (_,html) = reportFormlet formlet 66 | val = either (const Nothing) Just $ value 67 | return (html,fmap unpack val) 68 | 69 | handleDelete :: HPCtrl () 70 | handleDelete = 71 | withAuth $ \_ -> do 72 | pid <- (>>= readMay) . fmap (toString) <$> getParam "id" 73 | case pid of 74 | Nothing -> goReport 75 | Just (pid :: Integer) -> do 76 | model $ deletePaste pid 77 | goReport 78 | 79 | -- | Go back to the reported page. 80 | goReport :: HPCtrl () 81 | goReport = withAuth $ \key -> redirect (fromString ("/reported?key=" ++ key)) 82 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Cache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | 3 | -- | HTML caching. 4 | 5 | module Hpaste.Controller.Cache 6 | (newCache 7 | ,cache 8 | ,cacheIf 9 | ,resetCache 10 | ,resetCacheModel) 11 | where 12 | 13 | 14 | import Hpaste.Types.Cache 15 | import Hpaste.Types.Config 16 | 17 | import Control.Concurrent 18 | import Control.Monad 19 | import Control.Monad.IO (io) 20 | import Control.Monad.Reader (asks) 21 | import qualified Data.Map as M 22 | import Data.Text.Lazy (Text) 23 | import qualified Data.Text.Lazy.IO as T 24 | import Snap.App.Types 25 | import System.Directory 26 | import Text.Blaze.Html5 (Html) 27 | import Text.Blaze.Renderer.Text (renderHtml) 28 | 29 | -- | Create a new cache. 30 | newCache :: IO Cache 31 | newCache = do 32 | var <- newMVar M.empty 33 | return $ Cache var 34 | 35 | -- | Cache conditionally. 36 | cacheIf :: Bool -> Key -> Controller Config s (Maybe Html) -> Controller Config s (Maybe Text) 37 | cacheIf pred key generate = 38 | if pred 39 | then cache key generate 40 | else fmap (fmap renderHtml) generate 41 | 42 | -- | Generate and save into the cache, or retrieve existing from the 43 | -- | cache. 44 | cache :: Key -> Controller Config s (Maybe Html) -> Controller Config s (Maybe Text) 45 | cache key generate = do 46 | tmpdir <- asks (configCacheDir . controllerStateConfig) 47 | let cachePath = tmpdir ++ "/" ++ keyToString key 48 | exists <- io $ doesFileExist cachePath 49 | if exists 50 | then do text <- io $ T.readFile cachePath 51 | return (Just text) 52 | else do text <- fmap (fmap renderHtml) generate 53 | case text of 54 | Just text' -> do io $ T.writeFile cachePath text' 55 | return text 56 | Nothing -> return text 57 | 58 | -- | Reset an item in the cache. 59 | resetCache :: Key -> Controller Config s () 60 | resetCache key = do 61 | tmpdir <- asks (configCacheDir . controllerStateConfig) 62 | io $ do 63 | let cachePath = tmpdir ++ "/" ++ keyToString key 64 | exists <- io $ doesFileExist cachePath 65 | when exists $ removeFile cachePath 66 | 67 | -- | Reset an item in the cache. 68 | resetCacheModel :: Key -> Model Config s () 69 | resetCacheModel key = do 70 | tmpdir <- asks (configCacheDir . modelStateConfig) 71 | io $ do 72 | let cachePath = tmpdir ++ "/" ++ keyToString key 73 | exists <- io $ doesFileExist cachePath 74 | when exists $ removeFile cachePath 75 | 76 | keyToString :: Key -> String 77 | keyToString Home = "home.html" 78 | keyToString Activity = "activity.html" 79 | keyToString (Paste i) = "paste-" ++ show i ++ ".html" 80 | keyToString (Revision i) = "revision-" ++ show i ++ ".html" 81 | -------------------------------------------------------------------------------- /src/Hpaste/View/Stepeval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Stepeval explanation view. 6 | 7 | module Hpaste.View.Stepeval 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Highlight 13 | import Hpaste.View.Hlint 14 | import Hpaste.View.Html 15 | import Hpaste.View.Layout 16 | 17 | import Data.Monoid.Operator ((++)) 18 | import Data.Text (Text) 19 | import Language.Haskell.HLint 20 | import Prelude hiding ((++)) 21 | import Text.Blaze.Html5 as H hiding (map) 22 | 23 | -- | Render the page page. 24 | page :: StepevalPage -> Html 25 | page StepevalPage{..} = 26 | layoutPage $ Page { 27 | pageTitle = "Stepeval support" 28 | , pageBody = do explanation 29 | viewPaste sePaste seHints 30 | , pageName = "paste" 31 | } 32 | 33 | explanation :: Html 34 | explanation = do 35 | lightSection "Stepeval" $ do 36 | p $ do "A program/library for evaluating " 37 | "a Haskell expression step-by-step. This web site uses it " 38 | "for stepping through provided expressions." 39 | p $ href ("https://github.com/benmachine/stepeval" :: Text) 40 | ("Repository for Stepeval" :: Text) 41 | p $ do "Stepeval comes with a simple Prelude of pure functions " 42 | "(see below) that can be used when stepping through " 43 | "expressions. This may be expanded upon in the future." 44 | p $ do "This web site will automatically include declarations " 45 | "from the paste as the expression to be evaluted." 46 | 47 | -- | View a paste's details and content. 48 | viewPaste :: Text -> [Suggestion] -> Html 49 | viewPaste paste hints = do 50 | pasteDetails "Stepeval Prelude" 51 | pasteContent paste 52 | viewSuggestions hints 53 | 54 | -- | List the details of the page in a dark section. 55 | pasteDetails :: Text -> Html 56 | pasteDetails title = 57 | darkNoTitleSection $ do 58 | pasteNav 59 | h2 $ toHtml title 60 | ul ! aClass "paste-specs" $ do 61 | detail "Language" $ "Haskell" 62 | detail "Raw" $ href ("/stepeval/raw" :: Text) 63 | ("View raw link" :: Text) 64 | clear 65 | 66 | where detail title content = do 67 | li $ do strong (title ++ ":"); content 68 | 69 | -- | Individual paste navigation. 70 | pasteNav :: Html 71 | pasteNav = 72 | H.div ! aClass "paste-nav" $ do 73 | href ("https://github.com/benmachine/stepeval" :: Text) 74 | ("Go to stepeval project" :: Text) 75 | 76 | -- | Show the paste content with highlighting. 77 | pasteContent :: Text -> Html 78 | pasteContent paste = 79 | lightNoTitleSection $ 80 | highlightHaskell paste -------------------------------------------------------------------------------- /src/Hpaste/View/Browse.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Browse page view. 6 | 7 | module Hpaste.View.Browse 8 | (page) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | import Hpaste.View.Layout 14 | import Hpaste.View.Paste (pasteLink) 15 | 16 | import Control.Monad 17 | import Data.Maybe 18 | import Data.Monoid.Operator 19 | import Data.Pagination 20 | import qualified Data.Text as T 21 | import qualified Data.Text.Lazy as LT 22 | import Data.Time 23 | import Data.Time.Relative 24 | import Network.URI 25 | import Network.URI.Params 26 | import Prelude hiding ((++)) 27 | import Snap.App.Types 28 | import System.Locale 29 | import Text.Blaze.Extra 30 | import Text.Blaze.Html5 as H hiding (map) 31 | import qualified Text.Blaze.Html5.Attributes as A 32 | import Text.Blaze.Pagination 33 | 34 | -- | Render the browse page. 35 | page :: UTCTime -> PN -> [Channel] -> [Language] -> [Paste] -> Maybe String -> Html 36 | page now pn chans langs ps mauthor = 37 | layoutPage $ Page { 38 | pageTitle = "Browse pastes" 39 | , pageBody = browse now pn chans langs ps mauthor 40 | , pageName = "browse" 41 | } 42 | 43 | -- | View the paginated pastes. 44 | browse :: UTCTime -> PN -> [Channel] -> [Language] -> [Paste] -> Maybe String -> Html 45 | browse now pn channels languages ps mauthor = do 46 | darkSection title $ do 47 | pagination pn 48 | table ! aClass "latest-pastes" $ do 49 | tr $ mapM_ (th . (toHtml :: String -> Html)) $ 50 | ["Title"] ++ ["Author"|isNothing mauthor] ++ ["When","Language","Channel"] 51 | pastes ps 52 | pagination pn { pnPn = (pnPn pn) { pnShowDesc = False } } 53 | 54 | where pastes = mapM_ $ \paste@Paste{..} -> tr $ do 55 | td $ pasteLink paste pasteTitle 56 | unless (isJust mauthor) $ 57 | td $ do 58 | let author = T.unpack pasteAuthor 59 | if True -- validNick author 60 | then a ! hrefURI (authorUri author) $ toHtml pasteAuthor 61 | else toHtml pasteAuthor 62 | td $ ago pasteDate now 63 | td $ showLanguage languages pasteLanguage 64 | td $ showChannel Nothing channels pasteChannel 65 | authorUri author = updateUrlParam "author" author 66 | $ updateUrlParam "pastes_page" "0" 67 | $ pnURI pn 68 | title = LT.pack $ case mauthor of 69 | Just author -> "Pastes by " ++ author 70 | Nothing -> "Latest pastes" 71 | 72 | epoch = formatTime defaultTimeLocale "%s" 73 | 74 | ago t1 t2 = H.span !. "relative-time" 75 | ! dataAttribute "epoch" (toValue (epoch t1)) 76 | ! A.title (toValue (show t1)) $ 77 | toHtml (relative t1 t2 True) 78 | -------------------------------------------------------------------------------- /src/Hpaste/View/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Page layout. 6 | 7 | module Hpaste.View.Layout 8 | (layoutPage) 9 | where 10 | 11 | import Hpaste.Types 12 | import Hpaste.View.Html 13 | 14 | import Data.Monoid.Operator ((++)) 15 | import Prelude hiding ((++)) 16 | import Text.Blaze.Html5 as H hiding (map,nav) 17 | import qualified Text.Blaze.Html5.Attributes as A 18 | 19 | -- | Render the page in a layout. 20 | layoutPage :: Page -> Markup 21 | layoutPage Page{..} = do 22 | docTypeHtml $ do 23 | H.head $ do 24 | meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8" 25 | link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/css/amelie.css" 26 | js "jquery.js" 27 | js "amelie.js" 28 | js "highlight.pack.js" 29 | title $ toMarkup $ pageTitle ++ " :: lpaste — Lambda pastebin" 30 | script $ 31 | "hljs.tabReplace = ' ';hljs.initHighlightingOnLoad();" 32 | body ! A.id (toValue pageName) $ do 33 | wrap $ do 34 | nav 35 | logo 36 | pageBody 37 | foot 38 | preEscapedString "" 47 | 48 | where js s = script ! A.type_ "text/javascript" 49 | ! A.src ("/js/" ++ s) $ 50 | return () 51 | 52 | -- | Show the lpaste logo. 53 | logo :: Markup 54 | logo = return () 55 | 56 | -- | Layout wrapper. 57 | wrap :: Markup -> Markup 58 | wrap x = H.div ! aClass "wrap" $ x 59 | 60 | -- | Navigation. 61 | nav :: Markup 62 | nav = do 63 | H.div ! aClass "nav" $ do 64 | a ! aClass "logo" ! A.href "/" $ "λ" 65 | a ! A.href "/browse" $ "Browse" 66 | a ! A.href "mailto:chrisdone@gmail.com" $ "Contact" 67 | -- " | " 68 | -- a ! A.href "/activity" $ "Changes" 69 | 70 | -- | Page footer. 71 | foot :: Markup 72 | foot = H.div ! aClass "footer" $ p $ 73 | lnk "http://github.com/chrisdone/lpaste" "Web site source code on Github" 74 | // 75 | lnk "http://book.realworldhaskell.org/" "Real World Haskell" 76 | // 77 | lnk "http://haskell.org/" "Haskell.org" 78 | // 79 | lnk "http://planet.haskell.org/" "Planet Haskell" 80 | 81 | where lnk url t = href (url :: String) (t :: String) 82 | left // right = do _ <- left; (" / " :: Markup); right 83 | -------------------------------------------------------------------------------- /src/Hpaste/View/Steps.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Paste steps view. 6 | 7 | module Hpaste.View.Steps 8 | (page 9 | ,exprFormlet) 10 | where 11 | 12 | import Hpaste.Types 13 | import Hpaste.View.Highlight 14 | import Hpaste.View.Hlint (viewHints) 15 | import Hpaste.View.Html 16 | import Hpaste.View.Layout 17 | import Hpaste.View.Paste (pasteLink) 18 | 19 | import Control.Monad 20 | import Data.Monoid.Operator ((++)) 21 | import Data.Text (Text) 22 | import qualified Data.Text as T 23 | import Data.Text.Lazy (fromStrict) 24 | import Prelude hiding ((++),div) 25 | import Text.Blaze.Html5 as H hiding (map) 26 | import qualified Text.Blaze.Html5.Attributes as A 27 | import Text.Formlet 28 | 29 | -- | Render the steps page. 30 | page :: StepsPage -> Html 31 | page StepsPage{spPaste=p@Paste{..},..} = 32 | layoutPage $ Page { 33 | pageTitle = pasteTitle 34 | , pageBody = viewPaste spForm p spHints spSteps 35 | , pageName = "steps" 36 | } 37 | 38 | -- | View a paste's details and content. 39 | viewPaste :: Html -> Paste -> [Hint] -> [Text] -> Html 40 | viewPaste form paste@Paste{..} hints steps = do 41 | case pasteParent of 42 | Nothing -> return () 43 | Just{} -> let an = "a" ++ show (fromIntegral pasteId :: Integer) 44 | in a ! A.name (toValue an) $ return () 45 | pasteDetails paste 46 | pasteContent paste 47 | stepsForm form 48 | viewSteps steps 49 | viewHints hints 50 | 51 | stepsForm :: Html -> Html 52 | stepsForm form = 53 | lightNoTitleSection $ 54 | div ! aClass "steps-expr" $ 55 | form 56 | 57 | -- | A formlet for expr submission / annotating. 58 | exprFormlet :: ExprFormlet -> (Formlet Text,Html) 59 | exprFormlet ExprFormlet{..} = 60 | let frm = form $ do 61 | formletHtml exprSubmit efParams 62 | submitInput "submit" "Submit" 63 | in (exprSubmit,frm) 64 | 65 | exprSubmit :: Formlet Text 66 | exprSubmit = req (textInput "expr" "Expression" Nothing) 67 | 68 | viewSteps :: [Text] -> Html 69 | viewSteps steps = 70 | lightSection "Steps (displaying 50 max.)" $ 71 | div ! aClass "steps" $ do 72 | highlightHaskell $ T.intercalate "\n\n" steps 73 | 74 | -- | List the details of the page in a dark section. 75 | pasteDetails :: Paste -> Html 76 | pasteDetails paste@Paste{..} = 77 | darkNoTitleSection $ do 78 | pasteNav 79 | h2 $ toHtml $ fromStrict pasteTitle 80 | ul ! aClass "paste-specs" $ do 81 | detail "Paste" $ pasteLink paste $ "#" ++ show pasteId 82 | detail "Author" $ pasteAuthor 83 | clear 84 | 85 | where detail title content = do 86 | li $ do strong (title ++ ":"); toHtml content 87 | 88 | -- | Individual paste navigation. 89 | pasteNav :: Html 90 | pasteNav = 91 | H.div ! aClass "paste-nav" $ do 92 | href ("/stepeval" :: Text) 93 | ("About evaluation step support" :: Text) 94 | 95 | -- | Show the paste content with highlighting. 96 | pasteContent :: Paste -> Html 97 | pasteContent paste = 98 | lightNoTitleSection $ highlightHaskell (pastePaste paste) 99 | -------------------------------------------------------------------------------- /src/Hpaste/View/Highlight.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | 7 | -- | Code highlighting. 8 | 9 | module Hpaste.View.Highlight 10 | (highlightPaste 11 | ,highlightHaskell) 12 | where 13 | 14 | import Hpaste.Types 15 | import Hpaste.View.Html 16 | 17 | import Data.Monoid 18 | import Control.Monad 19 | import Data.List (find) 20 | import Data.Monoid.Operator 21 | import Data.Text (Text,unpack,pack) 22 | import qualified Data.Text as T 23 | import Language.Haskell.HsColour.CSS (hscolour) 24 | import Prelude hiding ((++)) 25 | import Text.Blaze.Html5 as H hiding (map) 26 | import qualified Text.Blaze.Html5.Attributes as A 27 | 28 | -- | Syntax highlight the paste. 29 | highlightPaste :: [Language] -> Paste -> Html 30 | highlightPaste langs Paste{..} = 31 | H.table ! aClass "code" $ do 32 | td ! aClass "line-nums" $ do 33 | pre $ 34 | forM_ [1..length (T.lines pastePaste)] $ \i -> do 35 | let name = "line" ++ pack (show i) 36 | href ("#" ++ name) (toHtml i) ! A.id (toValue name) ! A.name (toValue name) 37 | "\n" 38 | td $ 39 | case lang of 40 | Just (Language{languageName}) 41 | | languageName == "literatehaskell" -> 42 | birdStyle pastePaste 43 | | elem languageName ["haskell","agda","idris","elm"] -> 44 | preEscapedString $ hscolour False (unpack pastePaste) 45 | Just (Language{..}) -> 46 | pre $ code ! A.class_ (toValue $ "language-" ++ lang) $ 47 | toHtml pastePaste 48 | where lang | languageName == "elisp" = "lisp" 49 | | otherwise = languageName 50 | _ -> 51 | pre $ toHtml pastePaste 52 | 53 | where lang = find ((==pasteLanguage) . Just . languageId) langs 54 | 55 | highlightHaskell :: Text -> Html 56 | highlightHaskell paste = 57 | H.table ! aClass "code" $ 58 | td $ preEscapedString $ hscolour False (unpack paste) 59 | 60 | birdStyle :: Text -> Html 61 | birdStyle = collect mempty (Right []) . map T.unpack . T.lines where 62 | collect doc acc (('>':(dropSpace -> hsline)):xs) = 63 | case acc of 64 | Right hslines -> collect doc (Right (hslines ++ hsline ++ "\n")) xs 65 | Left text -> collect (doc <> plaintext text) (Right (hsline ++ "\n")) xs 66 | collect doc acc (textline:xs) = 67 | case acc of 68 | Right hslines -> collect (doc <> highlight hslines) (Left (textline ++ "\n")) xs 69 | Left text -> collect doc (Left (text ++ textline ++ "\n")) xs 70 | collect doc acc [] = 71 | case acc of 72 | Right hslines -> doc <> highlight hslines 73 | Left text -> doc <> plaintext text 74 | highlight = preEscapedString . beaks . hscolour False 75 | plaintext = pre . toHtml 76 | dropSpace (' ':xs) = xs 77 | dropSpace xs = xs 78 | beaks x = "
" ++ unlines (map beakize (lines x)) ++ "
" where 79 | beakize ('<':'p':'r':'e':'>':code) = "
> " ++ code
80 |     beakize "
" = "" 81 | beakize code = "> " ++ code 82 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Spam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Spam detection. 6 | 7 | module Hpaste.Model.Spam where 8 | 9 | import Hpaste.Types 10 | import Data.Monoid 11 | import Data.Text (Text) 12 | import Control.Monad.IO 13 | import Control.Monad.Env 14 | import Control.Monad 15 | import qualified Data.Text.Lazy as LT 16 | import qualified Data.Text as T 17 | import System.Process hiding (env) 18 | import Snap.App 19 | import Network.Mail.Mime 20 | 21 | -- | Get a spam rating for the given potential paste. 22 | spamRating :: PasteSubmit -> Model Config s Integer 23 | spamRating ps = do 24 | score <- if definitelySpam ps 25 | then return 100 26 | else fmap (weighted ps) (io (getRating mail)) 27 | when (score > spamMaxLevel) $ reportBadScore ps score 28 | return score 29 | 30 | where mail = unlines ["from: noreply@hpaste.org" 31 | ,"subject: " ++ T.unpack (pasteSubmitTitle ps) 32 | ,"" 33 | ,T.unpack (pasteSubmitPaste ps)] 34 | 35 | reportBadScore PasteSubmit{..} score = do 36 | conf <- env modelStateConfig 37 | m <- io $ simpleMail (configAdmin conf) 38 | (configSiteAddy conf) 39 | ("Paste marked as spam: " <> pasteSubmitTitle) 40 | body 41 | body 42 | [] 43 | io $ renderSendMail m 44 | 45 | where body = LT.pack $ 46 | "Paste '" ++ T.unpack pasteSubmitTitle ++ "' by " ++ T.unpack pasteSubmitAuthor ++ " " ++ 47 | "has rating " ++ show score ++ " with content: " ++ 48 | T.unpack pasteSubmitPaste 49 | 50 | -- | Get the rating from spam assassin. 51 | getRating :: String -> IO Integer 52 | getRating mail = do 53 | (_,err,_) <- readProcessWithExitCode "spamc" ["-c"] mail 54 | return $ case reads err of 55 | [(n :: Double,_)] -> round (n*10) 56 | _ -> 50 57 | 58 | -- | Mark something as definitely spam. 59 | definitelySpam :: PasteSubmit -> Bool 60 | definitelySpam ps = 61 | T.isInfixOf "http://" (pasteSubmitTitle ps) || 62 | T.isInfixOf "http://" (pasteSubmitAuthor ps) || 63 | T.isInfixOf "stooorage" (allText ps) || 64 | T.isInfixOf "http://fur.ly" (allText ps) || 65 | T.isInfixOf "anekahosting.com" (allText ps) || 66 | justUrl 67 | where justUrl = 68 | (T.isPrefixOf "http://" paste || 69 | T.isPrefixOf "https://" paste) && 70 | lineCount == 1 71 | lineCount = length (filter (not . T.null) 72 | (map T.strip 73 | (T.lines paste))) 74 | paste = T.strip (pasteSubmitPaste ps) 75 | 76 | -- | Multiple the rating by weights specific to hpaste. 77 | weighted :: PasteSubmit -> Integer -> Integer 78 | weighted ps n = foldr ($) n weights where 79 | weights = [if T.isInfixOf "http://" text || T.isInfixOf "https://" text 80 | then (+ (20 * fromIntegral (T.count "http://" text + T.count "https://" text))) else id 81 | ,if pasteSubmitAuthor ps == "Anonymous Coward" || pasteSubmitAuthor ps == "Anonymous" 82 | then (+20) else id 83 | ] 84 | text = allText ps 85 | 86 | -- | Get the text of the paste. 87 | allText :: PasteSubmit -> Text 88 | allText PasteSubmit{..} = T.toLower $ pasteSubmitTitle <> " " <> pasteSubmitPaste 89 | 90 | -- | Maximum level, anything equal or above this is treated as definitely spam, ignored. 91 | spamMaxLevel = 100 92 | 93 | -- | Minimum level, anything equal or above this is treated as possibly spam, accepted but not listed. 94 | spamMinLevel = 60 95 | -------------------------------------------------------------------------------- /src/HJScript/Objects/JQuery/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module HJScript.Objects.JQuery.Extra where 7 | 8 | import HJScript 9 | import HJScript.Objects.JQuery 10 | import qualified HJScript.Objects.Math as Math 11 | import Prelude hiding ((++),max) 12 | 13 | -- | jQuery selector. 14 | j :: String -> JObject JQuery 15 | j = selectExpr . string 16 | 17 | -- | Set the width of a DOM element. 18 | setWidth :: IsJQuery o => Exp Int -> o -> HJScript () 19 | setWidth w o = do 20 | runExp $ methodCall "width" w o 21 | 22 | -- | Set the text of a DOM element. 23 | setText :: IsJQuery o => Exp String -> o -> HJScript () 24 | setText w o = do 25 | runExp $ methodCall "text" w o 26 | 27 | -- | Append an element to another. 28 | append :: IsJQuery o => Exp a -> o -> HJScript () 29 | append w o = do 30 | runExp $ methodCall "append" w o 31 | 32 | -- | Prepend an element before another. 33 | prepend :: IsJQuery o => Exp a -> o -> HJScript () 34 | prepend w o = do 35 | runExp $ methodCall "prepend" w o 36 | 37 | -- | Add a class to an object. 38 | addClass :: IsJQuery o => String -> o -> HJScript () 39 | addClass w o = do 40 | runExp $ methodCall "addClass" (string w) o 41 | 42 | -- | Does an object have a class? 43 | hasClass :: IsJQuery o => String -> o -> JBool 44 | hasClass w o = do 45 | methodCall "hasClass" (string w) o 46 | 47 | -- | Remove a class from an object. 48 | removeClass :: IsJQuery o => String -> o -> HJScript () 49 | removeClass w o = do 50 | runExp $ methodCall "removeClass" (string w) o 51 | 52 | -- | Set the width of a DOM element. 53 | css' :: IsJQuery o => String -> String -> o -> HJScript () 54 | css' key value o = do 55 | runExp $ methodCall "css" (string key,string value) o 56 | 57 | -- | Set the width of a DOM element. 58 | css :: IsJQuery o => String -> String -> o -> HJScript () 59 | css key value o = do 60 | runExp $ methodCall "css" (string key,string value) o 61 | 62 | -- | Get the width of a DOM element. 63 | getWidth :: IsJQuery o => o -> Exp Int 64 | getWidth o = do 65 | methodCall "width" () o 66 | 67 | -- | Get siblings of an elements. 68 | siblings :: IsJQuery o => String -> o -> JObject JQuery 69 | siblings q o = do 70 | methodCall "siblings" (string q) o 71 | 72 | -- | When toggling by clicking, run these events on this object. 73 | toggle :: IsJQuery o => HJScript JBool -> HJScript JBool -> o -> HJScript () 74 | toggle on off query = do 75 | fnon <- function $ \() -> on 76 | fnoff <- function $ \() -> off 77 | runExp $ methodCall "toggle" (fnon,fnoff) query 78 | 79 | -- | When toggling by hover, run these events on this object. 80 | hover :: IsJQuery o => HJScript JBool -> HJScript JBool -> o -> HJScript () 81 | hover on off query = do 82 | fnon <- function $ \() -> on 83 | fnoff <- function $ \() -> off 84 | runExp $ methodCall "hover" (fnon,fnoff) query 85 | 86 | -- | For each object in a jQuery selection. 87 | each :: IsJQuery o => HJScript JBool -> o -> HJScript () 88 | each script query = do 89 | fn <- function $ \() -> script 90 | runExp $ methodCall "each" fn query 91 | 92 | -- | The jQuery 'this' object. 93 | this' :: JObject JQuery 94 | this' = selectExpr (this :: JObject JQuery) 95 | 96 | -- | Parent of a jQuery object. 97 | parent :: IsJQuery o => o -> JObject JQuery 98 | parent o = callMethod "parent" () o 99 | 100 | -- | Max. 101 | mathMax :: Exp a -> Exp a -> Exp a 102 | mathMax a b = callMethod "max" (a,b) Math.Math 103 | 104 | -- | Simple instance so we can use number literals and simple 105 | -- | arithmetic. 106 | instance Num (Exp Int) where 107 | a + b = a .+. b 108 | a * b = a .*. b 109 | abs = undefined 110 | signum = undefined 111 | fromInteger = int . fromIntegral 112 | instance Eq (Exp Int) 113 | 114 | class (IsDeref o) => IsJQuery o 115 | instance IsJQuery (JObject JQuery) 116 | instance IsClass (Var JQuery) 117 | instance IsJQuery (Var JQuery) 118 | -------------------------------------------------------------------------------- /hpaste.cabal: -------------------------------------------------------------------------------- 1 | Name: hpaste 2 | Version: 1.2.0 3 | stability: Stable 4 | Synopsis: Haskell paste web site. 5 | Description: Haskell paste web site. Includes: syntax highlighting for 6 | various languages, HLint suggestions for Haskell, annotations, 7 | revisions, diffs between revisions, announcement to IRC channels, 8 | browsing of author's pastes, spam reporting/deletion, 9 | SpamAssassin-based spam protection, secret/private pastes. 10 | Homepage: http://hpaste.org/ 11 | License: GPL 12 | Author: Chris Done 13 | Maintainer: Chris Done 14 | Copyright: 2010-2013 by Chris Done 15 | Category: Web 16 | Build-type: Simple 17 | Cabal-version: >=1.2 18 | 19 | Executable hpaste 20 | Main-is: Main.hs 21 | Ghc-options: -threaded -Wall -O2 -fno-warn-name-shadowing 22 | Hs-source-dirs: src 23 | Other-modules: Control.Monad.IO 24 | Control.Monad.Catch 25 | Control.Monad.Env 26 | HJScript.Objects.JQuery.Extra 27 | Data.Monoid.Operator 28 | Data.String.Extra 29 | Data.String.ToString 30 | Data.Time.Show 31 | Data.Maybe.Extra 32 | Data.Text.ToText 33 | Data.Text.FromText 34 | Data.Either.Extra 35 | Main 36 | Snap.App 37 | Network.URI.Params 38 | Network.Email 39 | Network.SendEmail 40 | Hpaste.Types.Stepeval 41 | Hpaste.Types.Cache 42 | Hpaste.Types.Language 43 | Hpaste.Types.Channel 44 | Hpaste.Types.Config 45 | Hpaste.Types.Report 46 | Hpaste.Types.Page 47 | Hpaste.Types.Newtypes 48 | Hpaste.Types.Announcer 49 | Hpaste.Types.Paste 50 | Hpaste.Types.Activity 51 | Hpaste.Types 52 | Hpaste.Controller.Admin 53 | Hpaste.Controller.Home 54 | Hpaste.Controller.Raw 55 | Hpaste.Controller.Cache 56 | Hpaste.Controller.Reported 57 | Hpaste.Controller.Irclogs 58 | Hpaste.Controller.Browse 59 | Hpaste.Controller.Report 60 | Hpaste.Controller.Script 61 | Hpaste.Controller.New 62 | Hpaste.Controller.Paste 63 | Hpaste.Controller.Activity 64 | Hpaste.Controller.Diff 65 | Hpaste.Model.Irclogs 66 | Hpaste.Model.Language 67 | Hpaste.Model.Channel 68 | Hpaste.Model.Report 69 | Hpaste.Model.Announcer 70 | Hpaste.Model.Spam 71 | Hpaste.Model.Paste 72 | Hpaste.Model.Activity 73 | Hpaste.Config 74 | Hpaste.View.Html 75 | Hpaste.View.Home 76 | Hpaste.View.Stepeval 77 | Hpaste.View.Reported 78 | Hpaste.View.Layout 79 | Hpaste.View.Annotate 80 | Hpaste.View.Irclogs 81 | Hpaste.View.Browse 82 | Hpaste.View.Report 83 | Hpaste.View.Script 84 | Hpaste.View.Thanks 85 | Hpaste.View.New 86 | Hpaste.View.Edit 87 | Hpaste.View.Paste 88 | Hpaste.View.Activity 89 | Hpaste.View.Diff 90 | Hpaste.View.Hlint 91 | Hpaste.View.Steps 92 | Hpaste.View.Highlight 93 | Text.Blaze.Html5.Extra 94 | Build-depends: 95 | -- Hard versions 96 | Diff == 0.1.3 97 | ,blaze-html >= 0.6 98 | ,blaze-markup >= 0.5 99 | -- Soft versions 100 | ,base >= 4 && < 5 101 | ,named-formlet >= 0.2 102 | ,snap-app >= 0.6.0 103 | -- Free versions 104 | ,ConfigFile 105 | ,HJScript 106 | ,MissingH 107 | ,MonadCatchIO-transformers 108 | ,blaze-builder 109 | ,bytestring 110 | ,containers 111 | ,directory 112 | ,download-curl 113 | ,feed 114 | ,filepath 115 | ,haskell-src-exts 116 | ,hlint 117 | ,hscolour 118 | ,mtl 119 | ,network 120 | ,old-locale 121 | ,safe 122 | ,snap-core 123 | ,snap-server 124 | ,text 125 | ,time 126 | ,transformers 127 | ,utf8-string 128 | ,mime-mail 129 | ,cgi 130 | ,process 131 | ,postgresql-simple 132 | -------------------------------------------------------------------------------- /src/Hpaste/Model/Irclogs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS -fno-warn-name-shadowing #-} 4 | 5 | module Hpaste.Model.Irclogs where 6 | 7 | import Hpaste.Types 8 | 9 | import Control.Applicative 10 | import Control.Arrow 11 | import Control.Monad.IO 12 | import Control.Monad.Reader 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString as S 15 | import Data.Char 16 | import Data.Either 17 | import Data.List (find) 18 | import Data.List.Utils 19 | import Data.Maybe 20 | import Data.Monoid.Operator ((++)) 21 | import Data.Text (Text) 22 | import qualified Data.Text as T 23 | import Data.Text.Encoding 24 | import Data.Text.Encoding.Error (lenientDecode) 25 | import Data.Time 26 | import Network.Curl.Download 27 | import Prelude hiding ((++)) 28 | import System.Directory 29 | import System.FilePath 30 | import System.Locale 31 | 32 | -- | Get IRC logs for the given channel narrowed down to the given date/time. 33 | getNarrowedLogs :: String -- ^ Channel name. 34 | -> String -- ^ Date. 35 | -> String -- ^ Time. 36 | -> Controller (Either String [Text]) 37 | getNarrowedLogs channel year time = do 38 | case parseIrcDate year of 39 | Nothing -> return $ Left $ "Unable to parse year: " ++ year 40 | Just date -> do 41 | days <- mapM (getLogs channel . showIrcDate) [addDays (-1) date,date,addDays 1 date] 42 | let events = concat (rights days) 43 | return (Right (fromMaybe events 44 | (narrowBy (T.isPrefixOf datetime) events <|> 45 | narrowBy (T.isPrefixOf dateminute) events <|> 46 | narrowBy (T.isPrefixOf datehour) events <|> 47 | narrowBy (T.isPrefixOf datestr) events <|> 48 | narrowBy (T.isPrefixOf dateday) events))) 49 | 50 | where narrowBy pred events = 51 | case find pred (filter crap events) of 52 | Nothing -> Nothing 53 | Just _res -> Just $ narrow count pred (filter crap events) 54 | count = 50 55 | datetime = T.pack $ year ++ "-" ++ replace "-" ":" time 56 | dateminute = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 2 . reverse $ time) 57 | datehour = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 5 . reverse $ time) 58 | datestr = T.pack $ year ++ "-" 59 | dateday = T.pack $ reverse . drop 2 . reverse $ year 60 | crap = not . T.isPrefixOf " --- " . T.dropWhile (not . isSpace) 61 | 62 | -- | Narrow to surrounding predicate. 63 | narrow :: Int -> (a -> Bool) -> [a] -> [a] 64 | narrow n f = uncurry (++) . (reverse . take n . reverse *** take n) . break f 65 | 66 | -- | Get IRC logs for the given channel and date. 67 | getLogs :: String -- ^ Channel name. 68 | -> String -- ^ Date. 69 | -> Controller (Either String [Text]) 70 | getLogs channel year = do 71 | dir <- asks $ configIrcDir . controllerStateConfig 72 | io $ do 73 | now <- fmap (showIrcDate . utctDay) getCurrentTime 74 | result <- openURICached (year == now) (file dir) uri 75 | case result of 76 | Left err -> return $ Left $ uri ++ ": " ++ err 77 | Right bytes -> return $ Right (map addYear (T.lines (decodeUtf8With lenientDecode bytes))) 78 | 79 | where uri = "http://tunes.org/~nef/logs/" ++ channel ++ "/" ++ yearStr 80 | file dir = dir channel ++ "-" ++ yearStr 81 | yearStr = replace "-" "." (drop 2 year) 82 | addYear line = T.pack year ++ "-" ++ line 83 | 84 | -- | Open the URI and cache the result. 85 | openURICached :: Bool -> FilePath -> String -> IO (Either String ByteString) 86 | openURICached noCache path url = do 87 | exists <- doesFileExist path 88 | if exists && not noCache 89 | then fmap Right $ S.readFile path 90 | else do result <- openURI url 91 | case result of 92 | Right bytes -> S.writeFile path bytes 93 | _ -> return () 94 | return result 95 | 96 | -- | Parse an IRC date string into a date. 97 | parseIrcDate :: String -> Maybe Day 98 | parseIrcDate = parseTime defaultTimeLocale "%Y-%m-%d" 99 | 100 | -- | Show a date to an IRC date format. 101 | showIrcDate :: Day -> String 102 | showIrcDate = formatTime defaultTimeLocale "%Y-%m-%d" 103 | 104 | -- | Show a date to an IRC date format. 105 | showIrcDateTime :: UTCTime -> String 106 | showIrcDateTime = 107 | formatTime defaultTimeLocale "%Y-%m-%d/%H-%M-%S" . addUTCTime ((40*60)+((-9)*60*60)) 108 | -------------------------------------------------------------------------------- /src/Hpaste/Types/Paste.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-orphans #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | -- | The paste type. 7 | 8 | module Hpaste.Types.Paste 9 | (Paste(..) 10 | ,PasteType(..) 11 | ,PasteSubmit(..) 12 | ,PasteFormlet(..) 13 | ,ExprFormlet(..) 14 | ,PastePage(..) 15 | ,StepsPage(..) 16 | ,Hint(..) 17 | ,ReportFormlet(..) 18 | ,ReportSubmit(..)) 19 | where 20 | 21 | import Hpaste.Types.Newtypes 22 | import Hpaste.Types.Language 23 | import Hpaste.Types.Channel 24 | import Control.Applicative 25 | import Blaze.ByteString.Builder (toByteString) 26 | import Blaze.ByteString.Builder.Char.Utf8 as Utf8 (fromString) 27 | import Data.Text (Text,pack) 28 | import Data.Time (UTCTime,zonedTimeToUTC) 29 | import Database.PostgreSQL.Simple 30 | import Database.PostgreSQL.Simple.FromRow 31 | import Database.PostgreSQL.Simple.FromField 32 | import Database.PostgreSQL.Simple.ToField 33 | import Language.Haskell.HLint (Severity) 34 | import Snap.Core 35 | import Text.Blaze (ToMarkup(..),toMarkup) 36 | import Text.Blaze.Html5 (Markup) 37 | 38 | -- | A paste. 39 | data Paste = Paste { 40 | pasteId :: PasteId 41 | ,pasteTitle :: Text 42 | ,pasteDate :: UTCTime 43 | ,pasteAuthor :: Text 44 | ,pasteLanguage :: Maybe LanguageId 45 | ,pasteChannel :: Maybe ChannelId 46 | ,pastePaste :: Text 47 | ,pasteViews :: Integer 48 | ,pasteType :: PasteType 49 | } deriving Show 50 | 51 | instance ToMarkup Paste where 52 | toMarkup paste@Paste{..} = toMarkup $ pack $ show paste 53 | 54 | instance FromRow Paste where 55 | fromRow = do 56 | (pid,title,content,author,date,views,language,channel,annotation_of,revision_of) <- fromRow 57 | return $ Paste 58 | { pasteTitle = title 59 | , pasteAuthor = author 60 | , pasteLanguage = language 61 | , pasteChannel = channel 62 | , pastePaste = content 63 | , pasteDate = zonedTimeToUTC date 64 | , pasteId = pid 65 | , pasteViews = views 66 | , pasteType = case annotation_of of 67 | Just pid' -> AnnotationOf pid' 68 | _ -> case revision_of of 69 | Just pid' -> RevisionOf pid' 70 | _ -> NormalPaste 71 | } 72 | 73 | -- | The type of a paste. 74 | data PasteType 75 | = NormalPaste 76 | | AnnotationOf PasteId 77 | | RevisionOf PasteId 78 | deriving (Eq,Show) 79 | 80 | -- | A paste submission or annotate. 81 | data PasteSubmit = PasteSubmit { 82 | pasteSubmitId :: Maybe PasteId 83 | ,pasteSubmitType :: PasteType 84 | ,pasteSubmitTitle :: Text 85 | ,pasteSubmitAuthor :: Text 86 | ,pasteSubmitLanguage :: Maybe LanguageId 87 | ,pasteSubmitChannel :: Maybe ChannelId 88 | ,pasteSubmitPaste :: Text 89 | ,pasteSubmitSpamTrap :: Maybe Text 90 | } deriving Show 91 | 92 | data PasteFormlet = PasteFormlet { 93 | pfSubmitted :: Bool 94 | , pfErrors :: [Text] 95 | , pfParams :: Params 96 | , pfLanguages :: [Language] 97 | , pfChannels :: [Channel] 98 | , pfDefChan :: Maybe Text 99 | , pfAnnotatePaste :: Maybe Paste 100 | , pfEditPaste :: Maybe Paste 101 | , pfContent :: Maybe Text 102 | } 103 | 104 | data ExprFormlet = ExprFormlet { 105 | efSubmitted :: Bool 106 | , efParams :: Params 107 | } 108 | 109 | data PastePage = PastePage { 110 | ppPaste :: Paste 111 | , ppChans :: [Channel] 112 | , ppLangs :: [Language] 113 | , ppHints :: [Hint] 114 | , ppAnnotations :: [Paste] 115 | , ppRevisions :: [Paste] 116 | , ppAnnotationHints :: [[Hint]] 117 | , ppRevisionsHints :: [[Hint]] 118 | , ppRevision :: Bool 119 | } 120 | 121 | data StepsPage = StepsPage { 122 | spPaste :: Paste 123 | , spChans :: [Channel] 124 | , spLangs :: [Language] 125 | , spHints :: [Hint] 126 | , spSteps :: [Text] 127 | , spAnnotations :: [Paste] 128 | , spAnnotationHints :: [[Hint]] 129 | , spForm :: Markup 130 | } 131 | 132 | instance ToField Severity where 133 | toField = toField . show 134 | 135 | -- render = Escape . toByteString . Utf8.fromString . show 136 | -- {-# INLINE render #-} 137 | 138 | instance FromField Severity where 139 | fromField x y = fmap read (fromField x y) 140 | {-# INLINE fromField #-} 141 | 142 | -- | A hlint (or like) suggestion. 143 | data Hint = Hint { 144 | hintType :: Severity 145 | , hintContent :: String 146 | } 147 | 148 | instance FromRow Hint where 149 | fromRow = Hint <$> field <*> field 150 | 151 | -- instance QueryResults Hint where 152 | -- convertResults field values = Hint { 153 | -- hintType = severity 154 | -- , hintContent = content 155 | -- } 156 | -- where (severity,content) = convertResults field values 157 | 158 | data ReportFormlet = ReportFormlet { 159 | rfSubmitted :: Bool 160 | , rfParams :: Params 161 | } 162 | 163 | data ReportSubmit = ReportSubmit { 164 | rsPaste :: PasteId 165 | ,rsComments :: String 166 | } 167 | -------------------------------------------------------------------------------- /src/Hpaste/View/Html.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | HTML-specific view functions. 6 | 7 | module Hpaste.View.Html 8 | (aClass 9 | ,aClasses 10 | ,darkSection 11 | ,darkNoTitleSection 12 | ,lightSection 13 | ,lightNoTitleSection 14 | ,warnNoTitleSection 15 | ,errorNoTitleSection 16 | ,href 17 | ,clear 18 | ,showLanguage 19 | ,showChannel 20 | ,paginate 21 | ,preEscapedString) 22 | where 23 | 24 | import Hpaste.Types 25 | 26 | import Control.Arrow ((&&&)) 27 | import Control.Monad (when) 28 | import Data.Maybe (fromMaybe) 29 | import Data.Monoid.Operator ((++)) 30 | import Data.Pagination 31 | import Data.Text.Lazy (Text) 32 | import qualified Data.Text.Lazy as T 33 | import Network.URI.Params 34 | import Network.URI 35 | import Prelude hiding ((++)) 36 | import Text.Blaze.Html5 as H hiding (map,nav) 37 | import qualified Text.Blaze.Html5.Attributes as A 38 | import Text.Blaze.Extra 39 | import Snap.App.Types 40 | 41 | -- | A class prefixed with nothing. 42 | aClass :: AttributeValue -> Attribute 43 | aClass name = A.class_ (name) 44 | 45 | -- | A class prefixed with nothing. 46 | aClasses :: [Text] -> Attribute 47 | aClasses names = A.class_ $ 48 | toValue $ T.intercalate " " $ names 49 | 50 | -- | A warning section. 51 | warnNoTitleSection :: Markup -> Markup 52 | warnNoTitleSection inner = 53 | H.div ! aClasses ["section","section-warn"] $ do 54 | inner 55 | 56 | -- | An error section. 57 | errorNoTitleSection :: Markup -> Markup 58 | errorNoTitleSection inner = 59 | H.div ! aClasses ["section","section-error"] $ do 60 | inner 61 | 62 | -- | A dark section. 63 | darkSection :: Text -> Markup -> Markup 64 | darkSection title inner = 65 | H.div ! aClasses ["section","section-dark"] $ do 66 | h2 $ toMarkup title 67 | inner 68 | 69 | -- | A dark section. 70 | darkNoTitleSection :: Markup -> Markup 71 | darkNoTitleSection inner = 72 | H.div ! aClasses ["section","section-dark"] $ do 73 | inner 74 | 75 | -- | A light section. 76 | lightSection :: Text -> Markup -> Markup 77 | lightSection title inner = 78 | H.div ! aClasses ["section","section-light"] $ do 79 | h2 $ toMarkup title 80 | inner 81 | 82 | -- | A light section with no title. 83 | lightNoTitleSection :: Markup -> Markup 84 | lightNoTitleSection inner = 85 | H.div ! aClasses ["section","section-light"] $ do 86 | inner 87 | 88 | -- | An anchor link. 89 | href :: (ToValue location,ToMarkup html) => location -> html -> Markup 90 | href loc content = H.a ! A.href (toValue loc) $ toMarkup content 91 | 92 | -- | A clear:both element. 93 | clear :: Markup 94 | clear = H.div ! aClass "clear" $ return () 95 | 96 | -- | Show a language. 97 | showLanguage :: [Language] -> Maybe LanguageId -> Markup 98 | showLanguage languages lid = 99 | toMarkup $ fromMaybe "-" (lid >>= (`lookup` langs)) 100 | 101 | where langs = map (languageId &&& languageTitle) languages 102 | 103 | -- | Show a channel. 104 | showChannel :: Maybe Paste -> [Channel] -> Maybe ChannelId -> Markup 105 | showChannel paste channels lid = do 106 | toMarkup $ fromMaybe "-" chan 107 | case (paste,chan) of 108 | (Just paste,Just c) | c == "#haskell" -> do 109 | " " 110 | href ("http://ircbrowse.net/browse/haskell/?q=hpaste+" ++ show (pasteId paste)) $ 111 | ("Context in IRC logs" :: String) 112 | _ -> return () 113 | 114 | where langs = map (channelId &&& channelName) channels 115 | chan = (lid >>= (`lookup` langs)) 116 | 117 | -- | Render results with pagination. 118 | paginate :: URI -> Pagination -> Markup -> Markup 119 | paginate uri pn inner = do 120 | nav uri pn True 121 | inner 122 | nav uri pn False 123 | 124 | -- | Show a pagination navigation, with results count, if requested. 125 | nav :: URI -> Pagination -> Bool -> Markup 126 | nav uri pn@Pagination{..} showTotal = do 127 | H.div ! aClass "pagination" $ do 128 | H.div ! aClass "inner" $ do 129 | when (pnCurrentPage-1 > 0) $ navDirection uri pn (-1) "Previous" 130 | toMarkup (" " :: Text) 131 | when (pnTotal == pnPerPage) $ navDirection uri pn 1 "Next" 132 | when showTotal $ do 133 | br 134 | toMarkup $ results 135 | 136 | where results = unwords [show start ++ "—" ++ show end 137 | ,"results of" 138 | ,show pnTotal] 139 | start = 1 + (pnCurrentPage - 1) * pnTotal 140 | end = pnCurrentPage * pnTotal 141 | 142 | -- | Link to change navigation page based on a direction. 143 | navDirection :: URI -> Pagination -> Integer -> Text -> Markup 144 | navDirection uri Pagination{..} change caption = do 145 | a ! hrefURI uri $ toMarkup caption 146 | 147 | where uri = updateUrlParam "page" 148 | (show (pnCurrentPage + change)) 149 | uri 150 | 151 | -- | Migration function. 152 | preEscapedString :: String -> Markup 153 | preEscapedString = preEscapedToMarkup 154 | -------------------------------------------------------------------------------- /src/Hpaste/Controller/Paste.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Paste controller. 6 | 7 | module Hpaste.Controller.Paste 8 | (handle 9 | ,pasteForm 10 | ,getPasteId 11 | ,getPasteIdKey 12 | ,withPasteKey) 13 | where 14 | 15 | import Hpaste.Types 16 | import Hpaste.Controller.Cache (cache,resetCache) 17 | import Hpaste.Model.Channel (getChannels) 18 | import Hpaste.Model.Language (getLanguages) 19 | import Hpaste.Model.Paste 20 | import Hpaste.Model.Spam 21 | import Hpaste.Types.Cache as Key 22 | import Hpaste.View.Paste (pasteFormlet,page) 23 | 24 | import Control.Applicative 25 | import Control.Monad ((>=>)) 26 | import Control.Monad.IO 27 | import Data.ByteString (ByteString) 28 | import Data.ByteString.UTF8 (toString) 29 | import Data.Maybe 30 | import Data.Monoid.Operator ((++)) 31 | import Data.String (fromString) 32 | import Data.Text (Text) 33 | import Prelude hiding ((++)) 34 | import Safe 35 | import Snap.App 36 | import Text.Blaze.Html5 as H hiding (output) 37 | import Text.Formlet 38 | 39 | -- | Handle the paste page. 40 | handle :: Bool -> HPCtrl () 41 | handle revision = do 42 | pid <- getPasteId 43 | justOrGoHome pid $ \(pid) -> do 44 | html <- cache (if revision then Key.Revision pid else Key.Paste pid) $ do 45 | getPrivate <- getParam "show_private" 46 | paste <- model $ if isJust getPrivate 47 | then getPrivatePasteById (pid) 48 | else getPasteById (pid) 49 | case paste of 50 | Nothing -> return Nothing 51 | Just paste -> do 52 | hints <- model $ getHints (pasteId paste) 53 | annotations <- model $ getAnnotations (pid) 54 | revisions <- model $ getRevisions (pid) 55 | ahints <- model $ mapM (getHints.pasteId) annotations 56 | rhints <- model $ mapM (getHints.pasteId) revisions 57 | chans <- model $ getChannels 58 | langs <- model $ getLanguages 59 | return $ Just $ page PastePage { 60 | ppChans = chans 61 | , ppLangs = langs 62 | , ppAnnotations = annotations 63 | , ppRevisions = revisions 64 | , ppHints = hints 65 | , ppPaste = paste 66 | , ppAnnotationHints = ahints 67 | , ppRevisionsHints = rhints 68 | , ppRevision = revision 69 | } 70 | justOrGoHome html outputText 71 | 72 | -- | Control paste annotating / submission. 73 | pasteForm :: [Channel] -> [Language] -> Maybe Text -> Maybe Paste -> Maybe Paste -> HPCtrl Html 74 | pasteForm channels languages defChan annotatePaste editPaste = do 75 | params <- getParams 76 | submittedPrivate <- isJust <$> getParam "private" 77 | submittedPublic <- isJust <$> getParam "public" 78 | revisions <- maybe (return []) (model . getRevisions) (fmap pasteId (annotatePaste <|> editPaste)) 79 | let formlet = PasteFormlet { 80 | pfSubmitted = submittedPrivate || submittedPublic 81 | , pfErrors = [] 82 | , pfParams = params 83 | , pfChannels = channels 84 | , pfLanguages = languages 85 | , pfDefChan = defChan 86 | , pfAnnotatePaste = annotatePaste 87 | , pfEditPaste = editPaste 88 | , pfContent = fmap pastePaste (listToMaybe revisions) 89 | } 90 | (getValue,_) = pasteFormlet formlet 91 | value = formletValue getValue params 92 | errors = either id (const []) value 93 | (_,html) = pasteFormlet formlet { pfErrors = errors } 94 | val = either (const Nothing) Just $ value 95 | case val of 96 | Nothing -> return () 97 | Just PasteSubmit{pasteSubmitSpamTrap=Just{}} -> goHome 98 | Just paste -> do 99 | spamrating <- model $ spamRating paste 100 | if spamrating >= spamMaxLevel 101 | then goSpamBlocked 102 | else do 103 | resetCache Key.Home 104 | maybe (return ()) (resetCache . Key.Paste) $ pasteSubmitId paste 105 | pid <- model $ createPaste languages channels paste spamrating submittedPublic 106 | maybe (return ()) redirectToPaste pid 107 | return html 108 | 109 | -- | Go back to the home page with a spam indication. 110 | goSpamBlocked :: HPCtrl () 111 | goSpamBlocked = redirect "/spam" 112 | 113 | -- | Redirect to the paste's page. 114 | redirectToPaste :: PasteId -> HPCtrl () 115 | redirectToPaste (PasteId pid) = 116 | redirect $ "/" ++ fromString (show pid) 117 | 118 | -- | Get the paste id. 119 | getPasteId :: HPCtrl (Maybe PasteId) 120 | getPasteId = (fmap toString >=> (fmap PasteId . readMay)) <$> getParam "id" 121 | 122 | -- | Get the paste id by a key. 123 | getPasteIdKey :: ByteString -> HPCtrl (Maybe PasteId) 124 | getPasteIdKey key = (fmap toString >=> (fmap PasteId . readMay)) <$> getParam key 125 | 126 | -- | With the 127 | withPasteKey :: ByteString -> (Paste -> HPCtrl a) -> HPCtrl () 128 | withPasteKey key with = do 129 | pid <- getPasteIdKey key 130 | justOrGoHome pid $ \(pid ) -> do 131 | paste <- model $ getPasteById pid 132 | justOrGoHome paste $ \paste -> do 133 | _ <- with paste 134 | return () 135 | -------------------------------------------------------------------------------- /static/js/amelie.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * jQuery Cookie Plugin v1.1 3 | * https://github.com/carhartl/jquery-cookie 4 | * 5 | * Copyright 2011, Klaus Hartl 6 | * Dual licensed under the MIT or GPL Version 2 licenses. 7 | * http://www.opensource.org/licenses/mit-license.php 8 | * http://www.opensource.org/licenses/GPL-2.0 9 | */ 10 | (function($, document) { 11 | 12 | var pluses = /\+/g; 13 | function raw(s) { 14 | return s; 15 | } 16 | function decoded(s) { 17 | return decodeURIComponent(s.replace(pluses, ' ')); 18 | } 19 | 20 | $.cookie = function(key, value, options) { 21 | 22 | // key and at least value given, set cookie... 23 | if (arguments.length > 1 && (!/Object/.test(Object.prototype.toString.call(value)) || value == null)) { 24 | options = $.extend({}, $.cookie.defaults, options); 25 | 26 | if (value == null) { 27 | options.expires = -1; 28 | } 29 | 30 | if (typeof options.expires === 'number') { 31 | var days = options.expires, t = options.expires = new Date(); 32 | t.setDate(t.getDate() + days); 33 | } 34 | 35 | value = String(value); 36 | 37 | return (document.cookie = [ 38 | encodeURIComponent(key), '=', options.raw ? value : encodeURIComponent(value), 39 | options.expires ? '; expires=' + options.expires.toUTCString() : '', // use expires attribute, max-age is not supported by IE 40 | options.path ? '; path=' + options.path : '', 41 | options.domain ? '; domain=' + options.domain : '', 42 | options.secure ? '; secure' : '' 43 | ].join('')); 44 | } 45 | 46 | // key and possibly options given, get cookie... 47 | options = value || $.cookie.defaults || {}; 48 | var decode = options.raw ? raw : decoded; 49 | var cookies = document.cookie.split('; '); 50 | for (var i = 0, parts; (parts = cookies[i] && cookies[i].split('=')); i++) { 51 | if (decode(parts.shift()) === key) { 52 | return decode(parts.join('=')); 53 | } 54 | } 55 | return null; 56 | }; 57 | 58 | $.cookie.defaults = {}; 59 | 60 | })(jQuery, document); 61 | 62 | /******************************************************************************* 63 | * Date utilities 64 | */ 65 | 66 | Date.prototype.relative = function(t2,fix){ 67 | var t1 = this; 68 | var diff = t1 - t2; 69 | var minute = 60, hour = minute * 60, day = hour * 24, 70 | week = day * 7, month = day * 30, year = month * 12; 71 | return inRange( 72 | [0,'just now'], 73 | [5,'% seconds',1], 74 | [minute,'a minute'], 75 | [minute*2,'% minutes',minute], 76 | [minute*30,'half an hour'], 77 | [minute*31,'% minutes',minute], 78 | [hour,'an hour'], 79 | [hour*2,'% hours',hour], 80 | [hour*3,'a few hours'], 81 | [hour*4,'% hours',hour], 82 | [day,'a day'], 83 | [day*2,'% days',day], 84 | [week,'a week'], 85 | [week*2,'% weeks',week], 86 | [month,'a month'], 87 | [month*2,'% months',month], 88 | [year,'a year'], 89 | [year*2,'% years',year] 90 | ); 91 | function inRange() { 92 | var span = Math.abs(diff/1000); 93 | for (var i = arguments.length-1; i >= 0; i--) { 94 | var range = arguments[i]; 95 | if (span >= range[0]) { 96 | return ( 97 | (fix&& diff>0?'in ':'') + 98 | (range[1].match(/%/)? 99 | range[1].replace(/%/g,Math.round(span/(range[2]? range[2] : 1))) 100 | : range[1]) + 101 | (fix&& diff<0?' ago':'') 102 | ); 103 | } 104 | } 105 | } 106 | }; 107 | 108 | function refreshDates(){ 109 | $('.relative-time').each(function(){ 110 | var t = (new Date($(this).attr('data-epoch') * 1000)); 111 | var now = new Date(); 112 | $(this).text(t.relative(now,true)); 113 | }); 114 | } 115 | 116 | /******************************************************************************* 117 | * Main code. 118 | */ 119 | 120 | $(function(){ 121 | $('form').each(function(){ 122 | $(this).find('input[name=author]') 123 | .val($.cookie('author')) 124 | .change(function(){ 125 | $.cookie('author', $(this).val(), { expires: 365, path: '/' }); 126 | }); 127 | }); 128 | $('.hint').each(function (){ 129 | var var_2 = $(this); 130 | var_2.css('height','1em'); 131 | var_2.css('overflow','hidden'); 132 | var_2.parent().css('cursor','pointer'); 133 | var_2.parent().toggle(function (){ 134 | var_2.css('height','auto'); 135 | return false; 136 | },function (){ 137 | var_2.css('height','1em'); 138 | var_2.css('overflow','hidden'); 139 | return false; 140 | 141 | }); 142 | return true; 143 | }); 144 | $('.paste-nav').each(function (){ 145 | var var_6 = $('Expand'); 146 | var var_7 = $(this); 147 | var_7.prepend(' - '); 148 | var_7.prepend(var_6); 149 | var var_8 = var_7.siblings('.paste-specs'); 150 | var_8.css('display','none'); 151 | var_6.text('Expand'); 152 | var_6.toggle(function (){ 153 | var_8.css('display','block'); 154 | var_6.text('Collapse'); 155 | return false; 156 | 157 | },function (){ 158 | var_8.css('display','none'); 159 | var_6.text('Expand'); 160 | return false; 161 | 162 | }); 163 | return true; 164 | }); 165 | refreshDates(); 166 | setInterval(refreshDates,1000); 167 | }); 168 | -------------------------------------------------------------------------------- /static/css/amelie.css: -------------------------------------------------------------------------------- 1 | /* General stuff */ 2 | body { 3 | font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; 4 | font-size: 13px; 5 | padding: 0; 6 | margin: 0; 7 | background: #f7f7f7; 8 | } 9 | a { 10 | color: #4e6272; 11 | text-decoration: none; 12 | } 13 | a:hover { 14 | text-decoration: underline; 15 | } 16 | 17 | input,.text,select { 18 | font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; 19 | font-size: 14px; 20 | } 21 | textarea { 22 | font-family: "ubuntu mono", monaco, consolas, monospace; 23 | font-size: 15px; 24 | } 25 | 26 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 27 | /* Main wrapper */ 28 | 29 | .wrap { 30 | background: #ffffff; 31 | } 32 | 33 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 34 | /* General sections */ 35 | 36 | /* Bit of padding */ 37 | .section { 38 | margin: 1em; 39 | color: #444; 40 | } 41 | .nav + .section > h2 { 42 | margin-top: 0; 43 | } 44 | .nav + .section > .paste-nav + h2 { 45 | margin-top: 0.75em; 46 | } 47 | 48 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 49 | /* Navigation */ 50 | 51 | /* Main nav */ 52 | .nav { 53 | /* Positioning */ 54 | text-align: right; 55 | height: 45px; 56 | line-height: 45px; 57 | padding-right: 1em; 58 | /* Foreground color */ 59 | color: #97a6b2; 60 | text-shadow: 0 1px 0 rgba(255,255,255,.1), 0 0 30px rgba(255,255,255,.125); 61 | /* Background color */ 62 | background-color: #252b30; 63 | background-image: -moz-linear-gradient(top, #222222, #293845); 64 | background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#222222), to(#293845)); 65 | background-image: -webkit-linear-gradient(top, #222222, #293845); 66 | background-image: -o-linear-gradient(top, #222222, #293845); 67 | background-image: linear-gradient(to bottom, #222222, #293845); 68 | background-repeat: repeat-x; 69 | border-color: #4e6272; 70 | filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff222222', endColorstr='#ff293845', GradientType=0); 71 | } 72 | /* Links */ 73 | .nav a { 74 | color: #e5ebf0; 75 | text-decoration: none; 76 | } 77 | .nav a + a { 78 | margin-left: 1em; 79 | } 80 | 81 | .logo { 82 | position: absolute; 83 | font-size: 1.5em; 84 | left: 1em; 85 | font-weight: bold; 86 | color: #fff; 87 | opacity: 0.7; 88 | text-shadow: 2px 2px 1px #222; 89 | } 90 | .logo:hover { 91 | opacity: 1; 92 | } 93 | #home h2, #browse h2 { 94 | display: none; 95 | } 96 | 97 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 98 | /* Paste form */ 99 | 100 | input[name=title] { 101 | width: 20em; 102 | } 103 | input[name=author] { 104 | width: 8em; 105 | } 106 | select[name=language] { 107 | width: 7em; 108 | } 109 | select[name=channel] { 110 | width: 7em; 111 | } 112 | /* Hide the labels */ 113 | form > p > label > span { 114 | display: none; 115 | } 116 | /* Code area is big */ 117 | form > textarea { 118 | margin-top: 1em; 119 | display: block; 120 | width: 100%; 121 | height: 30em; 122 | } 123 | .paste-buttons { 124 | float: right; 125 | } 126 | .paste-buttons .public { 127 | cursor: pointer; 128 | padding-left: 1.5em; 129 | padding-right: 1.5em; 130 | } 131 | .paste-buttons .private { 132 | color: #555; 133 | } 134 | .paste-buttons .private:hover { 135 | color: #222; 136 | cursor: pointer; 137 | } 138 | .spam { display: none; } 139 | textarea,.text { 140 | border: 1px solid #aaa; 141 | border-radius: 0.1em; 142 | } 143 | .text + .text, 144 | .text + select, 145 | select + select { 146 | margin-left: 0.25em; 147 | } 148 | 149 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 150 | /* Colors */ 151 | 152 | pre .hs-comment { color:#555 } 153 | pre .hs-keyword { color:#397460 } 154 | pre .hs-str { color:#366354 } 155 | pre .hs-conid { color:#4F4371 } 156 | pre .hs-varop, pre .hs-keyglyph { color:#8f4e8b } 157 | pre .hs-varid { color:#333 } 158 | pre .hs-num { color:#4F4371 } 159 | pre .diff { color:#555 } 160 | pre code .title { color:#333 } 161 | pre code .string { color:#366354 } 162 | pre code .built_in { color:#397460 } 163 | pre code .preprocessor { color:#4F4371 } 164 | pre code .comment { color:#555 } 165 | pre code .command { color:#397460 } 166 | pre code .special { color:#333 } 167 | pre code .formula { color:#4F4371 } 168 | pre code .keyword { color:#397460 } 169 | pre code .number { color:#4F4371 } 170 | pre code .header { color:#555 } 171 | pre code .deletion { background-color:#FDD; color:#695B5B } 172 | pre code .addition { background-color:#DFD; color:#000 } 173 | pre { margin:0 } 174 | pre .hs-definition { color: #2e659c } 175 | 176 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 177 | /* Diffs */ 178 | 179 | .diff-first { 180 | background-color:#FDD; 181 | color:#695B5B 182 | } 183 | .diff-second { 184 | background-color:#DFD 185 | } 186 | 187 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 188 | /* Line numbers */ 189 | 190 | .code td { 191 | vertical-align:top 192 | } 193 | .line-nums pre { 194 | margin:0 1em 0 0; 195 | text-align:right 196 | } 197 | .line-nums pre a { 198 | text-decoration:none; 199 | color: #666; 200 | } 201 | .line-nums pre a:hover { 202 | color: blue; 203 | } 204 | 205 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 206 | /* Footer */ 207 | 208 | .footer { 209 | border-top: 1px solid #eee; 210 | background: #f7f7f7; 211 | padding: 1em; 212 | } 213 | .footer p { 214 | margin: 0; 215 | } 216 | 217 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 218 | /* Hints */ 219 | 220 | .section-warn,.section-error { 221 | padding: 0.6em; 222 | margin: 0; 223 | } 224 | .section-light + .section-warn, 225 | .section-light + .section-error { 226 | margin-top: 1em; 227 | } 228 | .section-error + .section-error, 229 | .section-warn + .section-warn, 230 | .section-error + .section-warn { 231 | border-top: 0; 232 | } 233 | .section-warn { 234 | background: #FFF9C7; 235 | color: #915c31; 236 | border-top: 1px solid #FFF178; 237 | border-bottom: 1px solid #FFF178 238 | } 239 | .section-error { 240 | background: #FFDFDF; 241 | color: #5b4444; 242 | border-top: 1px solid #EFB3B3; 243 | border-bottom: 1px solid #EFB3B3; 244 | } 245 | 246 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 247 | /* Pagination */ 248 | 249 | .pages-list { 250 | list-style-type: none; 251 | margin-left: 0; 252 | padding-left: 0; 253 | } 254 | .pages-list li { 255 | display: inline-block; 256 | } 257 | .pages-list li + li { 258 | margin-left: 1em; 259 | } 260 | .pages-list a.active { 261 | color: #222; 262 | font-weight: bold; 263 | cursor: default; 264 | } 265 | .pages-list a.active:hover, 266 | .pages-list li.disabled a:hover { 267 | text-decoration: none; 268 | cursor: default; 269 | } 270 | 271 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 272 | /* Browse page */ 273 | 274 | table th { 275 | text-align: left; 276 | padding-bottom: 0.5em; 277 | border-bottom: 1px solid #ccc; 278 | } 279 | table td { 280 | padding-right: 1em; 281 | padding-top: 1em; 282 | } 283 | 284 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 285 | /* Paste page */ 286 | 287 | .paste-nav { 288 | margin-top: 0.5em; 289 | color: #aaa; 290 | } 291 | .paste-nav a { 292 | color: #4e6272; 293 | } 294 | 295 | .section-dark { 296 | background: #f7f7f7; 297 | margin: 0 !important; 298 | padding-left: 1em; 299 | padding-top: 1em; 300 | padding-bottom: 0.5em; 301 | border-top: 1px solid #eee; 302 | border-bottom: 1px solid #eee; 303 | } 304 | .section-dark h2 { 305 | margin-bottom: 0; 306 | padding-bottom: 0; 307 | } 308 | .section-dark + .section-light { 309 | margin-top: 0; 310 | } 311 | 312 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 313 | /* Paste specs */ 314 | 315 | .paste-specs { 316 | list-style-type: none; 317 | padding-left: 0; 318 | } 319 | .paste-specs > li { 320 | line-height: 1.8em; 321 | } 322 | .paste-specs > li > strong { 323 | display: inline-block; 324 | width: 6em; 325 | } 326 | 327 | /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 328 | /* Literate haskell bird style */ 329 | 330 | .bird-code pre { 331 | } 332 | .bird-code .beak { 333 | color: #aaa; 334 | } -------------------------------------------------------------------------------- /src/Hpaste/Model/Paste.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# OPTIONS -Wall -fno-warn-name-shadowing #-} 7 | 8 | -- | Paste model. 9 | 10 | module Hpaste.Model.Paste 11 | (getLatestPastes 12 | ,getPasteById 13 | ,getPrivatePasteById 14 | ,createOrUpdate 15 | ,deletePaste 16 | ,createPaste 17 | ,getAnnotations 18 | ,getRevisions 19 | ,getPaginatedPastes 20 | ,countPublicPastes 21 | ,generateHints 22 | ,getHints 23 | ,validNick) 24 | where 25 | 26 | import Hpaste.Types 27 | import Hpaste.Model.Announcer 28 | import Hpaste.Model.Spam 29 | 30 | import Data.Pagination 31 | import Control.Applicative ((<$>),(<|>)) 32 | import Control.Exception as E 33 | import Control.Monad 34 | import Control.Monad.Env 35 | import Control.Monad.IO 36 | import Data.Char 37 | import Data.List (find,intercalate) 38 | import Data.Maybe 39 | import Data.Monoid.Operator ((++)) 40 | import Data.Text (Text,unpack,pack) 41 | import qualified Data.Text as T 42 | import Data.Text.IO as T (writeFile) 43 | import Data.Text.Lazy (fromStrict) 44 | import Language.Haskell.HLint 45 | import Prelude hiding ((++)) 46 | import Snap.App 47 | import System.Directory 48 | import System.FilePath 49 | 50 | deletePaste :: Integer -> HPModel () 51 | deletePaste pid = void (exec ["DELETE FROM paste WHERE id = ?"] (Only pid)) 52 | 53 | -- | Count public pastes. 54 | countPublicPastes :: Maybe String -> HPModel Integer 55 | countPublicPastes mauthor = do 56 | rows <- single ["SELECT COUNT(*)" 57 | ,"FROM public_toplevel_paste" 58 | ,"WHERE (? IS NULL) OR (author = ?) AND spamrating < ?"] 59 | (mauthor,mauthor,spamMinLevel) 60 | return $ fromMaybe 0 rows 61 | 62 | -- | Get the latest pastes. 63 | getLatestPastes :: Maybe ChannelId -> HPModel [Paste] 64 | getLatestPastes channel = 65 | query ["SELECT ",pasteFields 66 | ,"FROM public_toplevel_paste" 67 | ,"WHERE spamrating < ?" 68 | ,"AND channel = ? or ? is null" 69 | ,"ORDER BY created DESC" 70 | ,"LIMIT 20"] 71 | (spamMinLevel,channel,channel) 72 | 73 | -- | Get some paginated pastes. 74 | getPaginatedPastes :: Maybe String -> Pagination -> HPModel (Pagination,[Paste]) 75 | getPaginatedPastes mauthor pn@Pagination{..} = do 76 | total <- countPublicPastes mauthor 77 | rows <- query ["SELECT",pasteFields 78 | ,"FROM public_toplevel_paste" 79 | ,"WHERE (? IS NULL) OR (author = ?) AND spamrating < ?" 80 | ,"ORDER BY created DESC" 81 | ,"OFFSET " ++ show (max 0 (pnCurrentPage - 1) * pnPerPage) 82 | ,"LIMIT " ++ show pnPerPage] 83 | (mauthor,mauthor,spamMinLevel) 84 | return (pn { pnTotal = total },rows) 85 | 86 | -- | Get a paste by its id. 87 | getPasteById :: PasteId -> HPModel (Maybe Paste) 88 | getPasteById pid = 89 | listToMaybe <$> query ["SELECT ",pasteFields 90 | ,"FROM public_paste" 91 | ,"WHERE id = ?"] 92 | (Only pid) 93 | 94 | -- | Get a private paste by its id, regardless of any status. 95 | getPrivatePasteById :: PasteId -> HPModel (Maybe Paste) 96 | getPrivatePasteById pid = 97 | listToMaybe <$> query ["SELECT",pasteFields 98 | ,"FROM private_paste" 99 | ,"WHERE id = ?"] 100 | (Only pid) 101 | 102 | -- | Get annotations of a paste. 103 | getAnnotations :: PasteId -> HPModel [Paste] 104 | getAnnotations pid = 105 | query ["SELECT",pasteFields 106 | ,"FROM public_paste" 107 | ,"WHERE annotation_of = ?" 108 | ,"ORDER BY created ASC"] 109 | (Only pid) 110 | 111 | -- | Get revisions of a paste. 112 | getRevisions :: PasteId -> HPModel [Paste] 113 | getRevisions pid = do 114 | query ["SELECT",pasteFields 115 | ,"FROM public_paste" 116 | ,"WHERE revision_of = ? or id = ?" 117 | ,"ORDER BY created DESC"] 118 | (pid,pid) 119 | 120 | -- | Create a paste, or update an existing one. 121 | createOrUpdate :: [Language] -> [Channel] -> PasteSubmit -> Integer -> Bool -> HPModel (Maybe PasteId) 122 | createOrUpdate langs chans paste@PasteSubmit{..} spamrating public = do 123 | case pasteSubmitId of 124 | Nothing -> createPaste langs chans paste spamrating public 125 | Just pid -> do updatePaste pid paste 126 | return $ Just pid 127 | 128 | -- | Create a new paste (possibly annotating an existing one). 129 | createPaste :: [Language] -> [Channel] -> PasteSubmit -> Integer -> Bool -> HPModel (Maybe PasteId) 130 | createPaste langs chans ps@PasteSubmit{..} spamrating public = do 131 | pid <- generatePasteId public 132 | res <- single ["INSERT INTO paste" 133 | ,"(id,title,author,content,channel,language,annotation_of,revision_of,spamrating,public)" 134 | ,"VALUES" 135 | ,"(?,?,?,?,?,?,?,?,?,?)" 136 | ,"returning id"] 137 | (pid,pasteSubmitTitle,pasteSubmitAuthor,pasteSubmitPaste 138 | ,pasteSubmitChannel,pasteSubmitLanguage,ann_pid,rev_pid,spamrating,public) 139 | when (lang == Just "haskell") $ just res $ createHints ps 140 | just (pasteSubmitChannel >>= lookupChan) $ \chan -> 141 | just res $ \pid -> do 142 | when (spamrating < spamMinLevel) $ 143 | announcePaste pasteSubmitType (channelName chan) ps pid 144 | return (pasteSubmitId <|> res) 145 | 146 | where lookupChan cid = find ((==cid).channelId) chans 147 | lookupLang lid = find ((==lid).languageId) langs 148 | lang = pasteSubmitLanguage >>= (fmap languageName . lookupLang) 149 | just j m = maybe (return ()) m j 150 | ann_pid = case pasteSubmitType of AnnotationOf pid -> Just pid; _ -> Nothing 151 | rev_pid = case pasteSubmitType of RevisionOf pid -> Just pid; _ -> Nothing 152 | 153 | -- | Generate a fresh unique paste id. 154 | generatePasteId :: Bool -> HPModel PasteId 155 | generatePasteId public = do 156 | result <- if public 157 | then single ["SELECT NEXTVAL('paste_id_seq')"] () 158 | else single ["SELECT (RANDOM()*9223372036854775807) :: BIGINT"] () 159 | case result of 160 | Just pid@(PasteId i) -> do 161 | result <- single ["SELECT TRUE FROM paste WHERE id = ?"] (Only pid) 162 | case result :: Maybe PasteId of 163 | Just pid -> generatePasteId public 164 | _ -> return pid 165 | 166 | -- | Create the hints for a paste. 167 | createHints :: PasteSubmit -> PasteId -> HPModel () 168 | createHints ps pid = do 169 | hints <- generateHintsForPaste ps pid 170 | forM_ hints $ \hint -> 171 | exec ["INSERT INTO hint" 172 | ,"(paste,type,content)" 173 | ,"VALUES" 174 | ,"(?,?,?)"] 175 | (pid 176 | ,suggestionSeverity hint 177 | ,show hint) 178 | 179 | -- | Announce the paste. 180 | announcePaste :: PasteType -> Text -> PasteSubmit -> PasteId -> HPModel () 181 | announcePaste ptype channel PasteSubmit{..} pid = do 182 | conf <- env modelStateConfig 183 | verb <- getVerb 184 | unless (seemsLikeSpam pasteSubmitTitle || seemsLikeSpam pasteSubmitAuthor) $ do 185 | announcer <- env modelStateAnns 186 | io $ announce announcer pasteSubmitAuthor channel $ do 187 | nick ++ " " ++ verb ++ " “" ++ pasteSubmitTitle ++ "” at " ++ link conf 188 | where nick | validNick (unpack pasteSubmitAuthor) = pasteSubmitAuthor 189 | | otherwise = "“" ++ pasteSubmitAuthor ++ "”" 190 | link Config{..} = "http://" ++ pack configDomain ++ "/" ++ pid' 191 | pid' = case ptype of 192 | NormalPaste -> showPid pid 193 | AnnotationOf apid -> showPid apid ++ "#a" ++ showPid pid 194 | RevisionOf apid -> showPid apid 195 | getVerb = case ptype of 196 | NormalPaste -> return $ "pasted" 197 | AnnotationOf pid -> do 198 | paste <- getPasteById pid 199 | return $ case paste of 200 | Just Paste{..} -> "annotated “" ++ pasteTitle ++ "” with" 201 | Nothing -> "annotated a paste with" 202 | RevisionOf pid -> do 203 | paste <- getPasteById pid 204 | return $ case paste of 205 | Just Paste{..} -> "revised “" ++ pasteTitle ++ "”:" 206 | Nothing -> "revised a paste:" 207 | showPid (PasteId p) = pack $ show $ (p :: Integer) 208 | seemsLikeSpam = T.isInfixOf "http://" 209 | 210 | -- | Is a nickname valid? Digit/letter or one of these: -_/\\;()[]{}?`' 211 | validNick :: String -> Bool 212 | validNick s = first && all ok s && length s > 0 where 213 | ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'" 214 | first = all (\c -> isDigit c || isLetter c) $ take 1 s 215 | 216 | -- | Get hints for a Haskell paste from hlint. 217 | generateHintsForPaste :: PasteSubmit -> PasteId -> HPModel [Suggestion] 218 | generateHintsForPaste PasteSubmit{..} (PasteId pid) = io $ 219 | E.catch (generateHints (show pid) pasteSubmitPaste) 220 | (\SomeException{} -> return []) 221 | 222 | -- | Get hints for a Haskell paste from hlint. 223 | generateHints :: FilePath -> Text -> IO [Suggestion] 224 | generateHints pid contents = io $ do 225 | tmpdir <- getTemporaryDirectory 226 | let tmp = tmpdir pid ++ ".hs" 227 | exists <- doesFileExist tmp 228 | unless exists $ T.writeFile tmp $ contents 229 | !hints <- hlint [tmp,"--quiet","--ignore=Parse error"] 230 | removeFile tmp 231 | return hints 232 | 233 | getHints :: PasteId -> HPModel [Hint] 234 | getHints pid = 235 | query ["SELECT type,content" 236 | ,"FROM hint" 237 | ,"WHERE paste = ?"] 238 | (Only pid) 239 | 240 | -- | Update an existing paste. 241 | updatePaste :: PasteId -> PasteSubmit -> HPModel () 242 | updatePaste pid PasteSubmit{..} = do 243 | _ <- exec (["UPDATE paste" 244 | ,"SET"] 245 | ++ 246 | [intercalate ", " (map set (words fields))] 247 | ++ 248 | ["WHERE id = ?"]) 249 | (pasteSubmitTitle 250 | ,pasteSubmitAuthor 251 | ,pasteSubmitPaste 252 | ,pasteSubmitLanguage 253 | ,pasteSubmitChannel 254 | ,pid) 255 | return () 256 | 257 | where fields = "title author content language channel" 258 | set key = unwords [key,"=","?"] 259 | 260 | pasteFields = "id,title,content,author,created,views,language,channel,annotation_of,revision_of" 261 | -------------------------------------------------------------------------------- /sql/schema.sql: -------------------------------------------------------------------------------- 1 | -- 2 | -- PostgreSQL database dump 3 | -- 4 | 5 | SET statement_timeout = 0; 6 | SET client_encoding = 'UTF8'; 7 | SET standard_conforming_strings = on; 8 | SET check_function_bodies = false; 9 | SET client_min_messages = warning; 10 | 11 | -- 12 | -- Name: plpgsql; Type: EXTENSION; Schema: -; Owner: - 13 | -- 14 | 15 | CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog; 16 | 17 | 18 | -- 19 | -- Name: EXTENSION plpgsql; Type: COMMENT; Schema: -; Owner: - 20 | -- 21 | 22 | COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language'; 23 | 24 | 25 | -- 26 | -- Name: uuid-ossp; Type: EXTENSION; Schema: -; Owner: - 27 | -- 28 | 29 | CREATE EXTENSION IF NOT EXISTS "uuid-ossp" WITH SCHEMA public; 30 | 31 | 32 | -- 33 | -- Name: EXTENSION "uuid-ossp"; Type: COMMENT; Schema: -; Owner: - 34 | -- 35 | 36 | COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UUIDs)'; 37 | 38 | 39 | SET search_path = public, pg_catalog; 40 | 41 | SET default_tablespace = ''; 42 | 43 | SET default_with_oids = false; 44 | 45 | -- 46 | -- Name: channel; Type: TABLE; Schema: public; Owner: -; Tablespace: 47 | -- 48 | 49 | CREATE TABLE channel ( 50 | id integer NOT NULL, 51 | title character varying(28) NOT NULL 52 | ); 53 | 54 | 55 | -- 56 | -- Name: channel_id_seq; Type: SEQUENCE; Schema: public; Owner: - 57 | -- 58 | 59 | CREATE SEQUENCE channel_id_seq 60 | START WITH 1 61 | INCREMENT BY 1 62 | NO MINVALUE 63 | NO MAXVALUE 64 | CACHE 1; 65 | 66 | 67 | -- 68 | -- Name: channel_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: - 69 | -- 70 | 71 | ALTER SEQUENCE channel_id_seq OWNED BY channel.id; 72 | 73 | 74 | -- 75 | -- Name: hint; Type: TABLE; Schema: public; Owner: -; Tablespace: 76 | -- 77 | 78 | CREATE TABLE hint ( 79 | id integer NOT NULL, 80 | paste bigint, 81 | type text NOT NULL, 82 | content text NOT NULL 83 | ); 84 | 85 | 86 | -- 87 | -- Name: hint_id_seq; Type: SEQUENCE; Schema: public; Owner: - 88 | -- 89 | 90 | CREATE SEQUENCE hint_id_seq 91 | START WITH 1 92 | INCREMENT BY 1 93 | NO MINVALUE 94 | NO MAXVALUE 95 | CACHE 1; 96 | 97 | 98 | -- 99 | -- Name: hint_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: - 100 | -- 101 | 102 | ALTER SEQUENCE hint_id_seq OWNED BY hint.id; 103 | 104 | 105 | -- 106 | -- Name: language; Type: TABLE; Schema: public; Owner: -; Tablespace: 107 | -- 108 | 109 | CREATE TABLE language ( 110 | id integer NOT NULL, 111 | name character varying(32) NOT NULL, 112 | title character varying(64) NOT NULL, 113 | ordinal integer DEFAULT 0 NOT NULL, 114 | visible boolean DEFAULT false NOT NULL 115 | ); 116 | 117 | 118 | -- 119 | -- Name: language_id_seq; Type: SEQUENCE; Schema: public; Owner: - 120 | -- 121 | 122 | CREATE SEQUENCE language_id_seq 123 | START WITH 1 124 | INCREMENT BY 1 125 | NO MINVALUE 126 | NO MAXVALUE 127 | CACHE 1; 128 | 129 | 130 | -- 131 | -- Name: language_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: - 132 | -- 133 | 134 | ALTER SEQUENCE language_id_seq OWNED BY language.id; 135 | 136 | 137 | -- 138 | -- Name: paste; Type: TABLE; Schema: public; Owner: -; Tablespace: 139 | -- 140 | 141 | CREATE TABLE paste ( 142 | id bigint NOT NULL, 143 | title character varying(512) NOT NULL, 144 | content text NOT NULL, 145 | tags text, 146 | author character varying(128) NOT NULL, 147 | created timestamp with time zone DEFAULT now() NOT NULL, 148 | views integer DEFAULT 0 NOT NULL, 149 | language integer, 150 | channel integer, 151 | annotation_of bigint, 152 | expire timestamp with time zone, 153 | output text, 154 | public boolean DEFAULT true, 155 | revision_of bigint, 156 | spamrating integer DEFAULT 0 157 | ); 158 | 159 | 160 | -- 161 | -- Name: paste_id_seq; Type: SEQUENCE; Schema: public; Owner: - 162 | -- 163 | 164 | CREATE SEQUENCE paste_id_seq 165 | START WITH 1 166 | INCREMENT BY 1 167 | NO MINVALUE 168 | NO MAXVALUE 169 | CACHE 1; 170 | 171 | 172 | -- 173 | -- Name: paste_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: - 174 | -- 175 | 176 | ALTER SEQUENCE paste_id_seq OWNED BY paste.id; 177 | 178 | 179 | -- 180 | -- Name: report; Type: TABLE; Schema: public; Owner: -; Tablespace: 181 | -- 182 | 183 | CREATE TABLE report ( 184 | id bigint NOT NULL, 185 | paste bigint NOT NULL, 186 | comments text NOT NULL, 187 | created timestamp with time zone DEFAULT now() NOT NULL 188 | ); 189 | 190 | 191 | -- 192 | -- Name: private_paste; Type: VIEW; Schema: public; Owner: - 193 | -- 194 | 195 | CREATE VIEW private_paste AS 196 | SELECT paste.id, paste.title, paste.content, paste.author, paste.created, paste.views, paste.language, paste.channel, paste.annotation_of, paste.revision_of FROM paste WHERE (paste.id IN (SELECT report.paste FROM report)); 197 | 198 | 199 | -- 200 | -- Name: public_paste; Type: VIEW; Schema: public; Owner: - 201 | -- 202 | 203 | CREATE VIEW public_paste AS 204 | SELECT paste.id, paste.title, paste.content, paste.author, paste.created, paste.views, paste.language, paste.channel, paste.annotation_of, paste.revision_of, paste.spamrating, paste.public FROM paste WHERE (NOT (paste.id IN (SELECT report.paste FROM report))); 205 | 206 | 207 | -- 208 | -- Name: public_toplevel_paste; Type: VIEW; Schema: public; Owner: - 209 | -- 210 | 211 | CREATE VIEW public_toplevel_paste AS 212 | SELECT public_paste.id, public_paste.title, public_paste.content, public_paste.author, public_paste.created, public_paste.views, public_paste.language, public_paste.channel, public_paste.annotation_of, public_paste.revision_of, public_paste.spamrating FROM public_paste WHERE (((public_paste.annotation_of IS NULL) AND (public_paste.revision_of IS NULL)) AND public_paste.public); 213 | 214 | 215 | -- 216 | -- Name: report_id_seq; Type: SEQUENCE; Schema: public; Owner: - 217 | -- 218 | 219 | CREATE SEQUENCE report_id_seq 220 | START WITH 1 221 | INCREMENT BY 1 222 | NO MINVALUE 223 | NO MAXVALUE 224 | CACHE 1; 225 | 226 | 227 | -- 228 | -- Name: report_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: - 229 | -- 230 | 231 | ALTER SEQUENCE report_id_seq OWNED BY report.id; 232 | 233 | 234 | -- 235 | -- Name: step; Type: TABLE; Schema: public; Owner: -; Tablespace: 236 | -- 237 | 238 | CREATE TABLE step ( 239 | paste integer NOT NULL, 240 | step integer NOT NULL, 241 | content text NOT NULL 242 | ); 243 | 244 | 245 | -- 246 | -- Name: id; Type: DEFAULT; Schema: public; Owner: - 247 | -- 248 | 249 | ALTER TABLE ONLY channel ALTER COLUMN id SET DEFAULT nextval('channel_id_seq'::regclass); 250 | 251 | 252 | -- 253 | -- Name: id; Type: DEFAULT; Schema: public; Owner: - 254 | -- 255 | 256 | ALTER TABLE ONLY hint ALTER COLUMN id SET DEFAULT nextval('hint_id_seq'::regclass); 257 | 258 | 259 | -- 260 | -- Name: id; Type: DEFAULT; Schema: public; Owner: - 261 | -- 262 | 263 | ALTER TABLE ONLY language ALTER COLUMN id SET DEFAULT nextval('language_id_seq'::regclass); 264 | 265 | 266 | -- 267 | -- Name: id; Type: DEFAULT; Schema: public; Owner: - 268 | -- 269 | 270 | ALTER TABLE ONLY paste ALTER COLUMN id SET DEFAULT nextval('paste_id_seq'::regclass); 271 | 272 | 273 | -- 274 | -- Name: id; Type: DEFAULT; Schema: public; Owner: - 275 | -- 276 | 277 | ALTER TABLE ONLY report ALTER COLUMN id SET DEFAULT nextval('report_id_seq'::regclass); 278 | 279 | 280 | -- 281 | -- Name: channel_pkey; Type: CONSTRAINT; Schema: public; Owner: -; Tablespace: 282 | -- 283 | 284 | ALTER TABLE ONLY channel 285 | ADD CONSTRAINT channel_pkey PRIMARY KEY (id); 286 | 287 | 288 | -- 289 | -- Name: hint_pkey; Type: CONSTRAINT; Schema: public; Owner: -; Tablespace: 290 | -- 291 | 292 | ALTER TABLE ONLY hint 293 | ADD CONSTRAINT hint_pkey PRIMARY KEY (id); 294 | 295 | 296 | -- 297 | -- Name: language_pkey; Type: CONSTRAINT; Schema: public; Owner: -; Tablespace: 298 | -- 299 | 300 | ALTER TABLE ONLY language 301 | ADD CONSTRAINT language_pkey PRIMARY KEY (id); 302 | 303 | 304 | -- 305 | -- Name: paste_pkey; Type: CONSTRAINT; Schema: public; Owner: -; Tablespace: 306 | -- 307 | 308 | ALTER TABLE ONLY paste 309 | ADD CONSTRAINT paste_pkey PRIMARY KEY (id); 310 | 311 | 312 | -- 313 | -- Name: report_pkey; Type: CONSTRAINT; Schema: public; Owner: -; Tablespace: 314 | -- 315 | 316 | ALTER TABLE ONLY report 317 | ADD CONSTRAINT report_pkey PRIMARY KEY (id); 318 | 319 | 320 | -- 321 | -- Name: paste_author_index; Type: INDEX; Schema: public; Owner: -; Tablespace: 322 | -- 323 | 324 | CREATE INDEX paste_author_index ON paste USING btree (author); 325 | 326 | 327 | -- 328 | -- Name: paste_date_index; Type: INDEX; Schema: public; Owner: -; Tablespace: 329 | -- 330 | 331 | CREATE INDEX paste_date_index ON paste USING btree (created); 332 | 333 | 334 | -- 335 | -- Name: paste_title_index; Type: INDEX; Schema: public; Owner: -; Tablespace: 336 | -- 337 | 338 | CREATE INDEX paste_title_index ON paste USING btree (title); 339 | 340 | 341 | -- 342 | -- Name: hint_paste_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 343 | -- 344 | 345 | ALTER TABLE ONLY hint 346 | ADD CONSTRAINT hint_paste_fkey FOREIGN KEY (paste) REFERENCES paste(id) ON UPDATE CASCADE ON DELETE CASCADE; 347 | 348 | 349 | -- 350 | -- Name: paste_channel_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 351 | -- 352 | 353 | ALTER TABLE ONLY paste 354 | ADD CONSTRAINT paste_channel_fkey FOREIGN KEY (channel) REFERENCES channel(id); 355 | 356 | 357 | -- 358 | -- Name: paste_language_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 359 | -- 360 | 361 | ALTER TABLE ONLY paste 362 | ADD CONSTRAINT paste_language_fkey FOREIGN KEY (language) REFERENCES language(id); 363 | 364 | 365 | -- 366 | -- Name: paste_revision_of_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 367 | -- 368 | 369 | ALTER TABLE ONLY paste 370 | ADD CONSTRAINT paste_revision_of_fkey FOREIGN KEY (revision_of) REFERENCES paste(id) ON DELETE CASCADE; 371 | 372 | 373 | -- 374 | -- Name: report_paste_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 375 | -- 376 | 377 | ALTER TABLE ONLY report 378 | ADD CONSTRAINT report_paste_fkey FOREIGN KEY (paste) REFERENCES paste(id) ON UPDATE CASCADE ON DELETE CASCADE; 379 | 380 | 381 | -- 382 | -- Name: step_paste_fkey; Type: FK CONSTRAINT; Schema: public; Owner: - 383 | -- 384 | 385 | ALTER TABLE ONLY step 386 | ADD CONSTRAINT step_paste_fkey FOREIGN KEY (paste) REFERENCES paste(id); 387 | 388 | 389 | -- 390 | -- Name: public; Type: ACL; Schema: -; Owner: - 391 | -- 392 | 393 | REVOKE ALL ON SCHEMA public FROM PUBLIC; 394 | REVOKE ALL ON SCHEMA public FROM postgres; 395 | GRANT ALL ON SCHEMA public TO postgres; 396 | GRANT ALL ON SCHEMA public TO PUBLIC; 397 | 398 | 399 | -- 400 | -- PostgreSQL database dump complete 401 | -- 402 | 403 | -------------------------------------------------------------------------------- /src/Hpaste/View/Paste.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | Paste views. 6 | 7 | module Hpaste.View.Paste 8 | (pasteFormlet 9 | ,page 10 | ,pasteLink 11 | ,pasteRawLink) 12 | where 13 | 14 | 15 | import Hpaste.Types 16 | import Hpaste.View.Highlight (highlightPaste) 17 | import Hpaste.View.Hlint (viewHints) 18 | import Hpaste.View.Html 19 | import Hpaste.View.Layout 20 | 21 | import Control.Applicative 22 | import Control.Arrow ((&&&)) 23 | import Control.Monad 24 | import Data.ByteString.UTF8 (toString) 25 | import Data.List (find,nub) 26 | import qualified Data.Map as M 27 | import Data.Maybe 28 | import Data.Monoid.Operator ((++)) 29 | import Data.Text (Text,pack) 30 | import qualified Data.Text as T 31 | import Data.Text.Lazy (fromStrict) 32 | import Data.Time.Show (showDateTime) 33 | import Data.Traversable hiding (forM) 34 | 35 | import Prelude hiding ((++)) 36 | import Safe (readMay) 37 | import Text.Blaze.Html5 as H hiding (map) 38 | import qualified Text.Blaze.Html5.Attributes as A 39 | import Text.Blaze.Html5.Extra 40 | import Text.Blaze.Extra 41 | import Text.Formlet 42 | 43 | -- | Render the page page. 44 | page :: PastePage -> Markup 45 | page PastePage{ppPaste=p@Paste{..},..} = 46 | layoutPage $ Page { 47 | pageTitle = pasteTitle 48 | , pageBody = do viewPaste (if ppRevision then [] else ppRevisions) 49 | [] 50 | ppChans 51 | ppLangs 52 | (p,case ppRevisionsHints of (hints:_) -> hints; _ -> ppHints) 53 | viewAnnotations (p : ppAnnotations) 54 | ppChans 55 | ppLangs 56 | (zip ppAnnotations ppAnnotationHints) 57 | , pageName = "paste" 58 | } 59 | 60 | -- | A formlet for paste submission / annotateing. 61 | pasteFormlet :: PasteFormlet -> (Formlet PasteSubmit,Markup) 62 | pasteFormlet pf@PasteFormlet{..} = 63 | let form = postForm ! A.action (toValue action) $ do 64 | when pfSubmitted $ 65 | when (not (null pfErrors)) $ 66 | H.div ! aClass "errors" $ 67 | mapM_ (p . toMarkup) pfErrors 68 | H.div !. "paste-buttons" $ do submitI "private" "Private" !. "private" 69 | " " 70 | submitI "public" "Public" !. "public" 71 | formletHtml (pasteSubmit pf) pfParams 72 | 73 | in (pasteSubmit pf,form) 74 | 75 | where action = case pfAnnotatePaste of 76 | Just Paste{..} -> "/annotate/" ++ show (fromMaybe pasteId pasteParent) 77 | where pasteParent = case pasteType of 78 | AnnotationOf pid -> Just pid 79 | _ -> Nothing 80 | Nothing -> 81 | case pfEditPaste of 82 | Just Paste{..} -> "/edit/" ++ show pasteId 83 | Nothing -> "/new" 84 | 85 | 86 | -- | Make a submit (captioned) button. 87 | submitI :: Text -> Text -> Markup 88 | submitI name caption = 89 | H.input ! A.type_ "submit" 90 | ! A.name (toValue name) 91 | ! A.value (toValue caption) 92 | 93 | 94 | -- | The paste submitting formlet itself. 95 | pasteSubmit :: PasteFormlet -> Formlet PasteSubmit 96 | pasteSubmit pf@PasteFormlet{..} = 97 | PasteSubmit 98 | <$> pure (getPasteId pf) 99 | <*> pure (case pfAnnotatePaste of 100 | Just pid -> AnnotationOf (pasteId pid) 101 | _ -> case pfEditPaste of 102 | Just pid -> RevisionOf (pasteId pid) 103 | _ -> NormalPaste) 104 | <*> defaulting "No title" (textPlaceholder "title" "Title" (annotateTitle <|> editTitle)) 105 | <*> defaulting "Anonymous Coward" (textPlaceholder "author" "Author" Nothing) 106 | <*> parse (traverse lookupLang) 107 | (opt (dropPlace languages "language" (snd defChan))) 108 | <*> parse (traverse lookupChan) 109 | (opt (dropPlace channels "channel" (fst defChan))) 110 | <*> req (areaPlaceholder "paste" "Enter your code here" pfContent) 111 | <*> opt (wrap (H.div ! aClass "spam") (textInput "email" "Email" Nothing)) 112 | 113 | where defaulting def = fmap swap where 114 | swap "" = def 115 | swap x = x 116 | channels = options channelName channelName pfChannels 117 | languages = options languageName languageTitle pfLanguages 118 | 119 | lookupLang slug = findOption ((==slug).languageName) pfLanguages languageId 120 | lookupChan slug = findOption ((==slug).channelName) pfChannels channelId 121 | 122 | defChan = maybe (fromMaybe "" (annotateChan <|> editChan) 123 | ,fromMaybe "haskell" (annotateLanguage <|> editLanguage)) 124 | (channelName &&& makeChan . channelName) 125 | (pfDefChan >>= findChan) 126 | findChan name = find ((==name).T.drop 1.channelName) pfChannels 127 | makeChan "#haskell" = "haskell" 128 | makeChan "#idris" = "idris" 129 | makeChan "#agda" = "agda" 130 | makeChan "#yesod" = "haskell" 131 | makeChan "#emacs" = "elisp" 132 | makeChan _ = "" 133 | 134 | annotateTitle = ((++ " (annotation)") . pasteTitle) <$> pfAnnotatePaste 135 | annotateLanguage = join (fmap pasteLanguage pfAnnotatePaste) >>= findLangById 136 | annotateChan = join (fmap pasteChannel pfAnnotatePaste) >>= findChanById 137 | 138 | editTitle = Nothing 139 | editLanguage = join (fmap pasteLanguage pfEditPaste) >>= findLangById 140 | editChan = join (fmap pasteChannel pfEditPaste) >>= findChanById 141 | 142 | findChanById id = channelName <$> find ((==id).channelId) pfChannels 143 | findLangById id = languageName <$> find ((==id).languageId) pfLanguages 144 | 145 | -- | Make a text input formlet with a placeholder. 146 | textPlaceholder :: Text -> Text -> Maybe Text -> Formlet Text 147 | textPlaceholder name caption def = 148 | formlet name $ \value -> do 149 | input ! A.name (toValue name) 150 | ! A.value (toValue $ fromMaybe "" (value <|> def)) 151 | ! A.placeholder (toValue caption) 152 | ! A.class_ "text" 153 | 154 | -- | Make a textarea input with a placeholder. 155 | areaPlaceholder :: Text -> Text -> Maybe Text -> Formlet Text 156 | areaPlaceholder name caption def = 157 | formlet name $ \value -> do 158 | textarea ! A.placeholder (toValue caption) ! A.name (toValue name) $ 159 | toHtml $ fromMaybe "" (value <|> def) 160 | 161 | -- | Make a drop down input. 162 | dropPlace :: [(Text,Text)] -> Text -> Text -> Formlet Text 163 | dropPlace values name def = 164 | formlet name $ \value -> do 165 | select ! A.name (toValue name) $ 166 | forM_ values $ \(key,title) -> do 167 | let nonSelected = all ((/=value) . Just . fst) values 168 | defaulting = nonSelected && def == key 169 | selected 170 | | Just key == value = (! A.selected "selected") 171 | | defaulting = (! A.selected "selected") 172 | | otherwise = id 173 | selected $ option ! A.value (toValue key) $ toHtml title 174 | 175 | -- | Get the paste id. 176 | getPasteId :: PasteFormlet -> Maybe PasteId 177 | getPasteId PasteFormlet{..} = 178 | M.lookup "id" pfParams >>= 179 | readMay . concat . map toString >>= 180 | return . PasteId 181 | 182 | -- | View the paste's annotations. 183 | viewAnnotations :: [Paste] -> [Channel] -> [Language] -> [(Paste,[Hint])] -> Markup 184 | viewAnnotations pastes chans langs annotations = do 185 | mapM_ (viewPaste [] pastes chans langs) annotations 186 | 187 | -- | View a paste's details and content. 188 | viewPaste :: [Paste] -> [Paste] -> [Channel] -> [Language] -> (Paste,[Hint]) -> Markup 189 | viewPaste revisions annotations chans langs (paste@Paste{..},hints) = do 190 | pasteDetails revisions annotations chans langs paste 191 | pasteContent revisions langs paste 192 | viewHints hints 193 | 194 | -- | List the details of the page in a dark section. 195 | pasteDetails :: [Paste] -> [Paste] -> [Channel] -> [Language] -> Paste -> Markup 196 | pasteDetails revisions annotations chans langs paste = 197 | darkNoTitleSection $ do 198 | h2 $ toMarkup $ fromStrict (pasteTitle paste) 199 | pasteNav annotations paste 200 | ul ! aClass "paste-specs" $ do 201 | detail "Paste" $ do 202 | pasteLink paste $ "#" ++ show (pasteId paste) 203 | " " 204 | linkToParent paste 205 | detail "Author(s)" $ do 206 | let authors | null revisions = map pasteAuthor [paste] 207 | | otherwise = map pasteAuthor revisions 208 | htmlCommasAnd $ flip map (nub authors) $ \author -> 209 | linkAuthor author 210 | detail "Language" $ showLanguage langs (pasteLanguage paste) 211 | detail "Channel" $ showChannel (Just paste) chans (pasteChannel paste) 212 | detail "Created" $ showDateTime (pasteDate paste) 213 | unless (length revisions < 2) $ detail "Revisions" $ do 214 | br 215 | ul !. "revisions" $ listRevisions paste revisions 216 | clear 217 | 218 | where detail title content = do 219 | li $ do strong (title ++ ":"); toMarkup content 220 | 221 | -- | Link to an author. 222 | linkAuthor :: Text -> Markup 223 | linkAuthor author = href ("/browse?author=" ++ author) $ toMarkup author 224 | 225 | -- | Link to annotation/revision parents. 226 | linkToParent :: Paste -> Markup 227 | linkToParent paste = do 228 | case pasteType paste of 229 | NormalPaste -> return () 230 | AnnotationOf pid -> do "(an annotation of "; pidLink pid; ")" 231 | RevisionOf pid -> do "(a revision of "; pidLink pid; ")" 232 | 233 | -- | List the revisions of a paste. 234 | listRevisions :: Paste -> [Paste] -> Markup 235 | listRevisions _ [] = return () 236 | listRevisions p [x] = revisionDetails p x 237 | listRevisions p (x:y:xs) = do 238 | revisionDetails y x 239 | listRevisions p (y:xs) 240 | 241 | -- | List the details of a revision. 242 | revisionDetails :: Paste -> Paste -> Markup 243 | revisionDetails paste revision = li $ do 244 | toMarkup $ showDateTime (pasteDate revision) 245 | " " 246 | revisionLink revision $ do "#"; toMarkup (show (pasteId revision)) 247 | unless (pasteId paste == pasteId revision) $ do 248 | " " 249 | href ("/diff/" ++ show (pasteId paste) ++ "/" ++ show (pasteId revision)) $ 250 | ("(diff)" :: Markup) 251 | ": " 252 | toMarkup (pasteTitle revision) 253 | " (" 254 | linkAuthor (pasteAuthor revision) 255 | ")" 256 | 257 | -- | Individual paste navigation. 258 | pasteNav :: [Paste] -> Paste -> Markup 259 | pasteNav pastes paste = 260 | H.div ! aClass "paste-nav" $ do 261 | diffLink 262 | href ("/edit/" ++ pack (show pid) ++ "") ("Edit" :: Text) 263 | " - " 264 | href ("/annotate/" ++ pack (show pid) ++ "") ("Annotate" :: Text) 265 | " - " 266 | href ("/report/" ++ pack (show pid) ++ "") ("Report/Delete" :: Text) 267 | " - " 268 | pasteRawLink paste $ ("Raw" :: Text) 269 | 270 | where pid = pasteId paste 271 | pairs = zip (drop 1 pastes) pastes 272 | parent = fmap snd $ find ((==pid).pasteId.fst) $ pairs 273 | diffLink = do 274 | case listToMaybe pastes of 275 | Nothing -> return () 276 | Just Paste{pasteId=parentId} -> do 277 | href ("/diff/" ++ show parentId ++ "/" ++ show pid) 278 | ("Diff original" :: Text) 279 | case parent of 280 | Nothing -> return () 281 | Just Paste{pasteId=prevId} -> do 282 | when (pasteType paste /= AnnotationOf prevId) $ do 283 | " / " 284 | href ("/diff/" ++ show prevId ++ "/" ++ show pid) 285 | ("prev" :: Text) 286 | case listToMaybe pastes of 287 | Nothing -> return (); Just{} -> " - " 288 | 289 | -- | Show the paste content with highlighting. 290 | pasteContent :: [Paste] -> [Language] -> Paste -> Markup 291 | pasteContent revisions langs paste = 292 | case revisions of 293 | (rev:_) -> lightNoTitleSection $ highlightPaste langs rev 294 | _ -> lightNoTitleSection $ highlightPaste langs paste 295 | 296 | -- | The href link to a paste. 297 | pasteLink :: ToMarkup html => Paste -> html -> Markup 298 | pasteLink Paste{..} inner = href ("/" ++ show pasteId) inner 299 | 300 | -- | The href link to a paste pid. 301 | pidLink :: PasteId -> Markup 302 | pidLink pid = href ("/" ++ show pid) $ toMarkup $ "#" ++ show pid 303 | 304 | -- | The href link to a paste. 305 | revisionLink :: ToMarkup html => Paste -> html -> Markup 306 | revisionLink Paste{..} inner = href ("/revision/" ++ show pasteId) inner 307 | 308 | -- | The href link to a paste, raw content. 309 | pasteRawLink :: ToMarkup html => Paste -> html -> Markup 310 | pasteRawLink Paste{..} inner = href ("/raw/" ++ show pasteId) inner 311 | -------------------------------------------------------------------------------- /static/js/highlight-haskell.js: -------------------------------------------------------------------------------- 1 | /* 2 | Syntax highlighting with language autodetection. 3 | http://softwaremaniacs.org/soft/highlight/ 4 | */ 5 | 6 | var hljs = new function() { 7 | 8 | /* Utility functions */ 9 | 10 | function escape(value) { 11 | return value.replace(/&/gm, '&').replace(/'; 131 | } 132 | 133 | while (stream1.length || stream2.length) { 134 | var current = selectStream().splice(0, 1)[0]; 135 | result += escape(value.substr(processed, current.offset - processed)); 136 | processed = current.offset; 137 | if ( current.event == 'start') { 138 | result += open(current.node); 139 | nodeStack.push(current.node); 140 | } else if (current.event == 'stop') { 141 | var i = nodeStack.length; 142 | do { 143 | i--; 144 | var node = nodeStack[i]; 145 | result += (''); 146 | } while (node != current.node); 147 | nodeStack.splice(i, 1); 148 | while (i < nodeStack.length) { 149 | result += open(nodeStack[i]); 150 | i++; 151 | } 152 | } 153 | } 154 | result += value.substr(processed); 155 | return result; 156 | } 157 | 158 | /* Initialization */ 159 | 160 | function compileModes() { 161 | 162 | function compileMode(mode, language, is_default) { 163 | if (mode.compiled) 164 | return; 165 | 166 | if (!is_default) { 167 | mode.beginRe = langRe(language, mode.begin ? mode.begin : '\\B|\\b'); 168 | if (!mode.end && !mode.endsWithParent) 169 | mode.end = '\\B|\\b' 170 | if (mode.end) 171 | mode.endRe = langRe(language, mode.end); 172 | } 173 | if (mode.illegal) 174 | mode.illegalRe = langRe(language, mode.illegal); 175 | if (mode.relevance == undefined) 176 | mode.relevance = 1; 177 | if (mode.keywords) 178 | mode.lexemsRe = langRe(language, mode.lexems || hljs.IDENT_RE, true); 179 | for (var key in mode.keywords) { 180 | if (!mode.keywords.hasOwnProperty(key)) 181 | continue; 182 | if (mode.keywords[key] instanceof Object) 183 | mode.keywordGroups = mode.keywords; 184 | else 185 | mode.keywordGroups = {'keyword': mode.keywords}; 186 | break; 187 | } 188 | if (!mode.contains) { 189 | mode.contains = []; 190 | } 191 | // compiled flag is set before compiling submodes to avoid self-recursion 192 | // (see lisp where quoted_list contains quoted_list) 193 | mode.compiled = true; 194 | for (var i = 0; i < mode.contains.length; i++) { 195 | compileMode(mode.contains[i], language, false); 196 | } 197 | if (mode.starts) { 198 | compileMode(mode.starts, language, false); 199 | } 200 | } 201 | 202 | for (var i in languages) { 203 | if (!languages.hasOwnProperty(i)) 204 | continue; 205 | compileMode(languages[i].defaultMode, languages[i], true); 206 | } 207 | } 208 | 209 | /* 210 | Core highlighting function. Accepts a language name and a string with the 211 | code to highlight. Returns an object with the following properties: 212 | 213 | - relevance (int) 214 | - keyword_count (int) 215 | - value (an HTML string with highlighting markup) 216 | 217 | */ 218 | function highlight(language_name, value) { 219 | if (!compileModes.called) { 220 | compileModes(); 221 | compileModes.called = true; 222 | } 223 | 224 | function subMode(lexem, mode) { 225 | for (var i = 0; i < mode.contains.length; i++) { 226 | if (mode.contains[i].beginRe.test(lexem)) { 227 | return mode.contains[i]; 228 | } 229 | } 230 | } 231 | 232 | function endOfMode(mode_index, lexem) { 233 | if (modes[mode_index].end && modes[mode_index].endRe.test(lexem)) 234 | return 1; 235 | if (modes[mode_index].endsWithParent) { 236 | var level = endOfMode(mode_index - 1, lexem); 237 | return level ? level + 1 : 0; 238 | } 239 | return 0; 240 | } 241 | 242 | function isIllegal(lexem, mode) { 243 | return mode.illegalRe && mode.illegalRe.test(lexem); 244 | } 245 | 246 | function compileTerminators(mode, language) { 247 | var terminators = []; 248 | 249 | for (var i = 0; i < mode.contains.length; i++) { 250 | terminators.push(mode.contains[i].begin); 251 | } 252 | 253 | var index = modes.length - 1; 254 | do { 255 | if (modes[index].end) { 256 | terminators.push(modes[index].end); 257 | } 258 | index--; 259 | } while (modes[index + 1].endsWithParent); 260 | 261 | if (mode.illegal) { 262 | terminators.push(mode.illegal); 263 | } 264 | 265 | return langRe(language, '(' + terminators.join('|') + ')', true); 266 | } 267 | 268 | function eatModeChunk(value, index) { 269 | var mode = modes[modes.length - 1]; 270 | if (!mode.terminators) { 271 | mode.terminators = compileTerminators(mode, language); 272 | } 273 | mode.terminators.lastIndex = index; 274 | var match = mode.terminators.exec(value); 275 | if (match) 276 | return [value.substr(index, match.index - index), match[0], false]; 277 | else 278 | return [value.substr(index), '', true]; 279 | } 280 | 281 | function keywordMatch(mode, match) { 282 | var match_str = language.case_insensitive ? match[0].toLowerCase() : match[0] 283 | for (var className in mode.keywordGroups) { 284 | if (!mode.keywordGroups.hasOwnProperty(className)) 285 | continue; 286 | var value = mode.keywordGroups[className].hasOwnProperty(match_str); 287 | if (value) 288 | return [className, value]; 289 | } 290 | return false; 291 | } 292 | 293 | function processKeywords(buffer, mode) { 294 | if (!mode.keywords) 295 | return escape(buffer); 296 | var result = ''; 297 | var last_index = 0; 298 | mode.lexemsRe.lastIndex = 0; 299 | var match = mode.lexemsRe.exec(buffer); 300 | while (match) { 301 | result += escape(buffer.substr(last_index, match.index - last_index)); 302 | var keyword_match = keywordMatch(mode, match); 303 | if (keyword_match) { 304 | keyword_count += keyword_match[1]; 305 | result += '' + escape(match[0]) + ''; 306 | } else { 307 | result += escape(match[0]); 308 | } 309 | last_index = mode.lexemsRe.lastIndex; 310 | match = mode.lexemsRe.exec(buffer); 311 | } 312 | result += escape(buffer.substr(last_index, buffer.length - last_index)); 313 | return result; 314 | } 315 | 316 | function processBuffer(buffer, mode) { 317 | if (mode.subLanguage && languages[mode.subLanguage]) { 318 | var result = highlight(mode.subLanguage, buffer); 319 | keyword_count += result.keyword_count; 320 | return result.value; 321 | } else { 322 | return processKeywords(buffer, mode); 323 | } 324 | } 325 | 326 | function startNewMode(mode, lexem) { 327 | var markup = mode.className?'':''; 328 | if (mode.returnBegin) { 329 | result += markup; 330 | mode.buffer = ''; 331 | } else if (mode.excludeBegin) { 332 | result += escape(lexem) + markup; 333 | mode.buffer = ''; 334 | } else { 335 | result += markup; 336 | mode.buffer = lexem; 337 | } 338 | modes.push(mode); 339 | relevance += mode.relevance; 340 | } 341 | 342 | function processModeInfo(buffer, lexem, end) { 343 | var current_mode = modes[modes.length - 1]; 344 | if (end) { 345 | result += processBuffer(current_mode.buffer + buffer, current_mode); 346 | return false; 347 | } 348 | 349 | var new_mode = subMode(lexem, current_mode); 350 | if (new_mode) { 351 | result += processBuffer(current_mode.buffer + buffer, current_mode); 352 | startNewMode(new_mode, lexem); 353 | return new_mode.returnBegin; 354 | } 355 | 356 | var end_level = endOfMode(modes.length - 1, lexem); 357 | if (end_level) { 358 | var markup = current_mode.className?'':''; 359 | if (current_mode.returnEnd) { 360 | result += processBuffer(current_mode.buffer + buffer, current_mode) + markup; 361 | } else if (current_mode.excludeEnd) { 362 | result += processBuffer(current_mode.buffer + buffer, current_mode) + markup + escape(lexem); 363 | } else { 364 | result += processBuffer(current_mode.buffer + buffer + lexem, current_mode) + markup; 365 | } 366 | while (end_level > 1) { 367 | markup = modes[modes.length - 2].className?'':''; 368 | result += markup; 369 | end_level--; 370 | modes.length--; 371 | } 372 | var last_ended_mode = modes[modes.length - 1]; 373 | modes.length--; 374 | modes[modes.length - 1].buffer = ''; 375 | if (last_ended_mode.starts) { 376 | startNewMode(last_ended_mode.starts, ''); 377 | } 378 | return current_mode.returnEnd; 379 | } 380 | 381 | if (isIllegal(lexem, current_mode)) 382 | throw 'Illegal'; 383 | } 384 | 385 | var language = languages[language_name]; 386 | var modes = [language.defaultMode]; 387 | var relevance = 0; 388 | var keyword_count = 0; 389 | var result = ''; 390 | try { 391 | var index = 0; 392 | language.defaultMode.buffer = ''; 393 | do { 394 | var mode_info = eatModeChunk(value, index); 395 | var return_lexem = processModeInfo(mode_info[0], mode_info[1], mode_info[2]); 396 | index += mode_info[0].length; 397 | if (!return_lexem) { 398 | index += mode_info[1].length; 399 | } 400 | } while (!mode_info[2]); 401 | if(modes.length > 1) 402 | throw 'Illegal'; 403 | return { 404 | relevance: relevance, 405 | keyword_count: keyword_count, 406 | value: result 407 | } 408 | } catch (e) { 409 | if (e == 'Illegal') { 410 | return { 411 | relevance: 0, 412 | keyword_count: 0, 413 | value: escape(value) 414 | } 415 | } else { 416 | throw e; 417 | } 418 | } 419 | } 420 | 421 | /* 422 | Highlighting with language detection. Accepts a string with the code to 423 | highlight. Returns an object with the following properties: 424 | 425 | - language (detected language) 426 | - relevance (int) 427 | - keyword_count (int) 428 | - value (an HTML string with highlighting markup) 429 | - second_best (object with the same structure for second-best heuristically 430 | detected language, may be absent) 431 | 432 | */ 433 | function highlightAuto(text) { 434 | var result = { 435 | keyword_count: 0, 436 | relevance: 0, 437 | value: escape(text) 438 | }; 439 | var second_best = result; 440 | for (var key in languages) { 441 | if (!languages.hasOwnProperty(key)) 442 | continue; 443 | var current = highlight(key, text); 444 | current.language = key; 445 | if (current.keyword_count + current.relevance > second_best.keyword_count + second_best.relevance) { 446 | second_best = current; 447 | } 448 | if (current.keyword_count + current.relevance > result.keyword_count + result.relevance) { 449 | second_best = result; 450 | result = current; 451 | } 452 | } 453 | if (second_best.language) { 454 | result.second_best = second_best; 455 | } 456 | return result; 457 | } 458 | 459 | /* 460 | Post-processing of the highlighted markup: 461 | 462 | - replace TABs with something more useful 463 | - replace real line-breaks with '
' for non-pre containers 464 | 465 | */ 466 | function fixMarkup(value, tabReplace, useBR) { 467 | if (tabReplace) { 468 | value = value.replace(/^((<[^>]+>|\t)+)/gm, function(match, p1, offset, s) { 469 | return p1.replace(/\t/g, tabReplace); 470 | }) 471 | } 472 | if (useBR) { 473 | value = value.replace(/\n/g, '
'); 474 | } 475 | return value; 476 | } 477 | 478 | /* 479 | Applies highlighting to a DOM node containing code. Accepts a DOM node and 480 | two optional parameters for fixMarkup. 481 | */ 482 | function highlightBlock(block, tabReplace, useBR) { 483 | var text = blockText(block, useBR); 484 | var language = 'haskell'; 485 | var result = highlight(language, text); 486 | var original = nodeStream(block); 487 | if (original.length) { 488 | var pre = document.createElement('pre'); 489 | pre.innerHTML = result.value; 490 | result.value = mergeStreams(original, nodeStream(pre), text); 491 | } 492 | result.value = fixMarkup(result.value, tabReplace, useBR); 493 | 494 | var class_name = block.className; 495 | if (!class_name.match('(\\s|^)(language-)?' + language + '(\\s|$)')) { 496 | class_name = class_name ? (class_name + ' ' + language) : language; 497 | } 498 | if (/MSIE [678]/.test(navigator.userAgent) && block.tagName == 'CODE' && block.parentNode.tagName == 'PRE') { 499 | // This is for backwards compatibility only. IE needs this strange 500 | // hack becasue it cannot just cleanly replace block contents. 501 | var pre = block.parentNode; 502 | var container = document.createElement('div'); 503 | container.innerHTML = '
' + result.value + '
'; 504 | block = container.firstChild.firstChild; 505 | container.firstChild.className = pre.className; 506 | pre.parentNode.replaceChild(container.firstChild, pre); 507 | } else { 508 | block.innerHTML = result.value; 509 | } 510 | block.className = class_name; 511 | block.result = { 512 | language: language, 513 | kw: result.keyword_count, 514 | re: result.relevance 515 | }; 516 | if (result.second_best) { 517 | block.second_best = { 518 | language: result.second_best.language, 519 | kw: result.second_best.keyword_count, 520 | re: result.second_best.relevance 521 | }; 522 | } 523 | } 524 | 525 | /* 526 | Applies highlighting to all 
..
blocks on a page. 527 | */ 528 | function initHighlighting() { 529 | if (initHighlighting.called) 530 | return; 531 | initHighlighting.called = true; 532 | var pres = document.getElementsByTagName('pre'); 533 | for (var i = 0; i < pres.length; i++) { 534 | var code = findCode(pres[i]); 535 | if (code) 536 | highlightBlock(code, hljs.tabReplace); 537 | } 538 | } 539 | 540 | /* 541 | Attaches highlighting to the page load event. 542 | */ 543 | function initHighlightingOnLoad() { 544 | if (window.addEventListener) { 545 | window.addEventListener('DOMContentLoaded', initHighlighting, false); 546 | window.addEventListener('load', initHighlighting, false); 547 | } else if (window.attachEvent) 548 | window.attachEvent('onload', initHighlighting); 549 | else 550 | window.onload = initHighlighting; 551 | } 552 | 553 | var languages = {}; // a shortcut to avoid writing "this." everywhere 554 | 555 | /* Interface definition */ 556 | 557 | this.LANGUAGES = languages; 558 | this.highlight = highlight; 559 | this.highlightAuto = highlightAuto; 560 | this.fixMarkup = fixMarkup; 561 | this.highlightBlock = highlightBlock; 562 | this.initHighlighting = initHighlighting; 563 | this.initHighlightingOnLoad = initHighlightingOnLoad; 564 | 565 | // Common regexps 566 | this.IDENT_RE = '[a-zA-Z][a-zA-Z0-9_]*'; 567 | this.UNDERSCORE_IDENT_RE = '[a-zA-Z_][a-zA-Z0-9_]*'; 568 | this.NUMBER_RE = '\\b\\d+(\\.\\d+)?'; 569 | this.C_NUMBER_RE = '\\b(0x[A-Za-z0-9]+|\\d+(\\.\\d+)?)'; 570 | this.RE_STARTERS_RE = '!|!=|!==|%|%=|&|&&|&=|\\*|\\*=|\\+|\\+=|,|\\.|-|-=|/|/=|:|;|<|<<|<<=|<=|=|==|===|>|>=|>>|>>=|>>>|>>>=|\\?|\\[|\\{|\\(|\\^|\\^=|\\||\\|=|\\|\\||~'; 571 | 572 | // Common modes 573 | this.BACKSLASH_ESCAPE = { 574 | begin: '\\\\.', relevance: 0 575 | }; 576 | this.APOS_STRING_MODE = { 577 | className: 'string', 578 | begin: '\'', end: '\'', 579 | illegal: '\\n', 580 | contains: [this.BACKSLASH_ESCAPE], 581 | relevance: 0 582 | }; 583 | this.QUOTE_STRING_MODE = { 584 | className: 'string', 585 | begin: '"', end: '"', 586 | illegal: '\\n', 587 | contains: [this.BACKSLASH_ESCAPE], 588 | relevance: 0 589 | }; 590 | this.C_LINE_COMMENT_MODE = { 591 | className: 'comment', 592 | begin: '//', end: '$' 593 | }; 594 | this.C_BLOCK_COMMENT_MODE = { 595 | className: 'comment', 596 | begin: '/\\*', end: '\\*/' 597 | }; 598 | this.HASH_COMMENT_MODE = { 599 | className: 'comment', 600 | begin: '#', end: '$' 601 | }; 602 | this.NUMBER_MODE = { 603 | className: 'number', 604 | begin: this.NUMBER_RE, 605 | relevance: 0 606 | }; 607 | this.C_NUMBER_MODE = { 608 | className: 'number', 609 | begin: this.C_NUMBER_RE, 610 | relevance: 0 611 | }; 612 | 613 | // Utility functions 614 | this.inherit = function(parent, obj) { 615 | var result = {} 616 | for (var key in parent) 617 | result[key] = parent[key]; 618 | if (obj) 619 | for (var key in obj) 620 | result[key] = obj[key]; 621 | return result; 622 | } 623 | }(); 624 | 625 | /* 626 | Language: Haskell 627 | Author: Jeremy Hull 628 | */ 629 | 630 | hljs.LANGUAGES.haskell = function(){ 631 | var LABEL = { 632 | className: 'label', 633 | begin: '\\b[A-Z][\\w\']*', 634 | relevance: 0 635 | }; 636 | var CONTAINER = { 637 | className: 'container', 638 | begin: '\\(', end: '\\)', 639 | contains: [ 640 | {className: 'label', begin: '\\b[A-Z][\\w\\(\\)\\.\']*'}, 641 | {className: 'title', begin: '[_a-z][\\w\']*'} 642 | ] 643 | }; 644 | 645 | return { 646 | defaultMode: { 647 | keywords: { 648 | 'keyword': { 649 | 'let': 1, 'in': 1, 'if': 1, 'then': 1, 'else': 1, 'case': 1, 'of': 1, 650 | 'where': 1, 'do': 1, 'module': 1, 'import': 1, 'hiding': 1, 651 | 'qualified': 1, 'type': 1, 'data': 1, 'newtype': 1, 'deriving': 1, 652 | 'class': 1, 'instance': 1, 'null': 1, 'not': 1, 'as': 1 653 | } 654 | }, 655 | contains: [ 656 | { 657 | className: 'comment', 658 | begin: '--', end: '$' 659 | }, 660 | { 661 | className: 'comment', 662 | begin: '{-', end: '-}' 663 | }, 664 | { 665 | className: 'string', 666 | begin: '\\s+\'', end: '\'', 667 | contains: [hljs.BACKSLASH_ESCAPE], 668 | relevance: 0 669 | }, 670 | hljs.QUOTE_STRING_MODE, 671 | { 672 | className: 'import', 673 | begin: '\\bimport', end: '$', 674 | keywords: {'import': 1, 'qualified': 1, 'as': 1, 'hiding': 1}, 675 | contains: [CONTAINER] 676 | }, 677 | { 678 | className: 'module', 679 | begin: '\\bmodule', end: 'where', 680 | keywords: {'module': 1, 'where': 1}, 681 | contains: [CONTAINER] 682 | }, 683 | { 684 | className: 'class', 685 | begin: '\\b(class|instance|data|(new)?type)', end: '(where|$)', 686 | keywords: {'class': 1, 'where': 1, 'instance': 1,'data': 1,'type': 1,'newtype': 1, 'deriving': 1}, 687 | contains: [LABEL] 688 | }, 689 | hljs.C_NUMBER_MODE, 690 | { 691 | className: 'shebang', 692 | begin: '#!\\/usr\\/bin\\/env\ runhaskell', end: '$' 693 | }, 694 | LABEL, 695 | { 696 | className: 'title', begin: '^[_a-z][\\w\']*' 697 | } 698 | ] 699 | } 700 | }; 701 | }(); 702 | --------------------------------------------------------------------------------