packages feed

hpaste 1.1.0 → 1.2.0

raw patch · 73 files changed

+3989/−1 lines, 73 files

Files

hpaste.cabal view
@@ -1,5 +1,5 @@ Name:                hpaste-Version:             1.1.0+Version:             1.2.0 stability:           Stable Synopsis:            Haskell paste web site. Description: Haskell paste web site. Includes: syntax highlighting for@@ -20,6 +20,79 @@   Main-is:           Main.hs   Ghc-options:       -threaded -Wall -O2 -fno-warn-name-shadowing   Hs-source-dirs:    src+  Other-modules:     Control.Monad.IO+             Control.Monad.Catch+             Control.Monad.Env+             HJScript.Objects.JQuery.Extra+             Data.Monoid.Operator+             Data.String.Extra+             Data.String.ToString+             Data.Time.Show+             Data.Maybe.Extra+             Data.Text.ToText+             Data.Text.FromText+             Data.Either.Extra+             Main+             Snap.App+             Network.URI.Params+             Network.Email+             Network.SendEmail+             Hpaste.Types.Stepeval+             Hpaste.Types.Cache+             Hpaste.Types.Language+             Hpaste.Types.Channel+             Hpaste.Types.Config+             Hpaste.Types.Report+             Hpaste.Types.Page+             Hpaste.Types.Newtypes+             Hpaste.Types.Announcer+             Hpaste.Types.Paste+             Hpaste.Types.Activity+             Hpaste.Types+             Hpaste.Controller.Admin+             Hpaste.Controller.Home+             Hpaste.Controller.Raw+             Hpaste.Controller.Cache+             Hpaste.Controller.Reported+             Hpaste.Controller.Irclogs+             Hpaste.Controller.Browse+             Hpaste.Controller.Report+             Hpaste.Controller.Script+             Hpaste.Controller.New+             Hpaste.Controller.Paste+             Hpaste.Controller.Activity+             Hpaste.Controller.Style+             Hpaste.Controller.Diff+             Hpaste.Model.Irclogs+             Hpaste.Model.Language+             Hpaste.Model.Channel+             Hpaste.Model.Report+             Hpaste.Model.Announcer+             Hpaste.Model.Spam+             Hpaste.Model.Paste+             Hpaste.Model.Activity+             Hpaste.Config+             Hpaste.View.Html+             Hpaste.View.Home+             Hpaste.View.Stepeval+             Hpaste.View.Reported+             Hpaste.View.Layout+             Hpaste.View.Annotate+             Hpaste.View.Irclogs+             Hpaste.View.Browse+             Hpaste.View.Report+             Hpaste.View.Script+             Hpaste.View.Thanks+             Hpaste.View.New+             Hpaste.View.Edit+             Hpaste.View.Paste+             Hpaste.View.Activity+             Hpaste.View.Style+             Hpaste.View.Diff+             Hpaste.View.Hlint+             Hpaste.View.Steps+             Hpaste.View.Highlight+             Text.Blaze.Html5.Extra   Build-depends:     -- Hard versions     Diff                      == 0.1.3
+ src/Control/Monad/Catch.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE PackageImports #-}++module Control.Monad.Catch (module Control.Monad.CatchIO) where++import "MonadCatchIO-transformers" Control.Monad.CatchIO
+ src/Control/Monad/Env.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Abstraction of environment functions (could be state, could be+--   reader, whatever). Intended to ease migration from Reader/State.++module Control.Monad.Env+  (env)+  where++import Control.Monad.Reader++env :: MonadReader env m => (env -> val) -> m val+env = asks
+ src/Control/Monad/IO.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS -Wall #-}++module Control.Monad.IO where++import Control.Monad.Trans++io :: MonadIO m => IO a -> m a+io = liftIO
+ src/Data/Either/Extra.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Either.Extra where++-- | When a value is Right, do something with it, monadically.+whenRight :: Monad m => Either a b -> (b -> m c) -> m ()+whenRight (Right x) m = m x >> return ()+whenRight _         _ = return ()++-- | When a value is Left, do something with it, monadically.+whenLeft :: Monad m => Either a b -> (a -> m c) -> m ()+whenLeft (Left x) m = m x >> return ()+whenLeft _         _ = return ()
+ src/Data/Maybe/Extra.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Maybe.Extra where++-- | When a value is Just, do something with it, monadically.+whenJust :: Monad m => Maybe a -> (a -> m c) -> m ()+whenJust (Just a) m = m a >> return ()+whenJust _         _ = return ()
+ src/Data/Monoid/Operator.hs view
@@ -0,0 +1,8 @@+-- | Convenient operator.++module Data.Monoid.Operator where++import Data.Monoid++(++) :: (Monoid a) => a -> a -> a+(++) = mappend
+ src/Data/String/Extra.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | Instances that can be converted to a string.++module Data.String.ToString where++import           Data.ByteString+import qualified Data.ByteString.UTF8 as UTF8 (toString)++class ToString string where+  toString :: string -> String++instance ToString String where toString = id++(+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String+str1 +++ str2 = toString str1 ++ toString str2++instance ToString ByteString where toString = UTF8.toString
+ src/Data/String/ToString.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Instances that can be converted to a string.++module Data.String.ToString where++import           Data.ByteString+import qualified Data.ByteString.UTF8 as UTF8 (toString)++class ToString string where+  toString :: string -> String++instance ToString String where toString = id++(+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String+str1 +++ str2 = toString str1 ++ toString str2++instance ToString ByteString where toString = UTF8.toString
+ src/Data/Text/FromText.hs view
@@ -0,0 +1,11 @@+module Data.Text.FromText where++import Data.Text+import qualified Data.Text.Lazy as L+import Data.ByteString+import qualified Data.ByteString.Lazy as L++class FromText a where+  fromText :: Text -> Maybe a+  fromLazyText :: L.Text -> Maybe a+  fromLazyText = fromText . L.toStrict
+ src/Data/Text/ToText.hs view
@@ -0,0 +1,15 @@+module Data.Text.ToText where++import Data.Text+import qualified Data.Text.Lazy as L+import Data.ByteString+import Data.Text.Encoding+import qualified Data.ByteString.Lazy as L++class ToText a where+  toText :: a -> Text+  toLazyText :: a -> L.Text+  toLazyText = L.fromStrict . toText++instance ToText ByteString where+  toText = decodeUtf8
+ src/Data/Time/Show.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Date/time showing functions.++module Data.Time.Show+  (showDateTime)+  where+  +import Data.Time     (FormatTime,formatTime)+import System.Locale (defaultTimeLocale)++showDateTime :: FormatTime t => t -> String+showDateTime time = formatTime defaultTimeLocale "%F %T %Z" time
+ src/HJScript/Objects/JQuery/Extra.hs view
@@ -0,0 +1,117 @@+{-# OPTIONS -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module HJScript.Objects.JQuery.Extra where++import           HJScript+import           HJScript.Objects.JQuery+import qualified HJScript.Objects.Math   as Math+import           Prelude                 hiding ((++),max)++-- | jQuery selector.+j :: String -> JObject JQuery+j = selectExpr . string++-- | Set the width of a DOM element.+setWidth :: IsJQuery o => Exp Int -> o -> HJScript ()+setWidth w o = do+  runExp $ methodCall "width" w o++-- | Set the text of a DOM element.+setText :: IsJQuery o => Exp String -> o -> HJScript ()+setText w o = do+  runExp $ methodCall "text" w o++-- | Append an element to another.+append :: IsJQuery o => Exp a -> o -> HJScript ()+append w o = do+  runExp $ methodCall "append" w o+  +-- | Prepend an element before another.+prepend :: IsJQuery o => Exp a -> o -> HJScript ()+prepend w o = do+  runExp $ methodCall "prepend" w o++-- | Add a class to an object.+addClass :: IsJQuery o => String -> o -> HJScript ()+addClass w o = do+  runExp $ methodCall "addClass" (string w) o++-- | Does an object have a class?+hasClass :: IsJQuery o => String -> o -> JBool+hasClass w o = do+  methodCall "hasClass" (string w) o++-- | Remove a class from an object.+removeClass :: IsJQuery o => String -> o -> HJScript ()+removeClass w o = do+  runExp $ methodCall "removeClass" (string w) o++-- | Set the width of a DOM element.+css' :: IsJQuery o => String -> String -> o -> HJScript ()+css' key value o = do+  runExp $ methodCall "css" (string key,string value) o++-- | Set the width of a DOM element.+css :: IsJQuery o => String -> String -> o -> HJScript ()+css key value o = do+  runExp $ methodCall "css" (string key,string value) o++-- | Get the width of a DOM element.+getWidth :: IsJQuery o => o -> Exp Int+getWidth o = do+  methodCall "width" () o++-- | Get siblings of an elements.+siblings :: IsJQuery o => String -> o -> JObject JQuery+siblings q o = do+  methodCall "siblings" (string q) o++-- | When toggling by clicking, run these events on this object.+toggle :: IsJQuery o => HJScript JBool -> HJScript JBool -> o -> HJScript ()+toggle on off query = do+  fnon <- function $ \() -> on+  fnoff <- function $ \() -> off+  runExp $ methodCall "toggle" (fnon,fnoff) query++-- | When toggling by hover, run these events on this object.+hover :: IsJQuery o => HJScript JBool -> HJScript JBool -> o -> HJScript ()+hover on off query = do+  fnon <- function $ \() -> on+  fnoff <- function $ \() -> off+  runExp $ methodCall "hover" (fnon,fnoff) query++-- | For each object in a jQuery selection.+each :: IsJQuery o => HJScript JBool -> o -> HJScript ()+each script query = do+  fn <- function $ \() -> script+  runExp $ methodCall "each" fn query++-- | The jQuery 'this' object.+this' :: JObject JQuery+this' = selectExpr (this :: JObject JQuery)++-- | Parent of a jQuery object.+parent :: IsJQuery o => o -> JObject JQuery+parent o = callMethod "parent" () o++-- | Max.+mathMax :: Exp a -> Exp a -> Exp a+mathMax a b = callMethod "max" (a,b) Math.Math++-- | Simple instance so we can use number literals and simple+-- | arithmetic.+instance Num (Exp Int) where+  a + b = a .+. b+  a * b = a .*. b+  abs = undefined+  signum = undefined+  fromInteger = int . fromIntegral+instance Eq (Exp Int)++class (IsDeref o) => IsJQuery o+instance IsJQuery (JObject JQuery)+instance IsClass (Var JQuery)+instance IsJQuery (Var JQuery)
+ src/Hpaste/Config.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-}++-- | Load the configuration file.++module Hpaste.Config+       (getConfig)+       where++import Hpaste.Types.Config+import Hpaste.Model.Announcer++import Data.ConfigFile+import Database.PostgreSQL.Simple (ConnectInfo(..))+import qualified Data.Text as T+import Network.Mail.Mime++getConfig :: FilePath -> IO Config+getConfig conf = do+  contents <- readFile conf+  let config = do+        c <- readstring emptyCP contents+        [user,pass,host,port]+          <- mapM (get c "ANNOUNCE")+                  ["user","pass","host","port"]+        [pghost,pgport,pguser,pgpass,pgdb]+          <- mapM (get c "POSTGRESQL")+                  ["host","port","user","pass","db"]+        [domain,cache]+          <- mapM (get c "WEB")+                  ["domain","cache"]+        [commits,url]+          <- mapM (get c "DEV")+                  ["commits","repo_url"]+        [ircDir]+          <- mapM (get c "IRC")+                  ["log_dir"]+        [admin,siteaddy]+          <- mapM (get c "ADDRESSES")+	     	  ["admin","site_addy"]+        [key] <- mapM (get c "ADMIN") ["key"]+                  +        return Config {+           configAnnounce = AnnounceConfig user pass host (read port)+         , configPostgres = ConnectInfo pghost (read pgport) pguser pgpass pgdb+         , configDomain = domain+         , configCommits = commits+         , configRepoURL = url+         , configIrcDir = ircDir+	 , configAdmin = Address Nothing (T.pack admin)+	 , configSiteAddy = Address Nothing (T.pack siteaddy)+	 , configCacheDir = cache+	 , configKey = key+         }+  case config of+    Left cperr -> error $ show cperr+    Right config -> return config
+ src/Hpaste/Controller/Activity.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Activity page controller.++module Hpaste.Controller.Activity+  (handle)+  where++import Hpaste.Types+import Hpaste.Controller.Cache (cache)+import Hpaste.Model.Activity   (getCommits)+import Hpaste.Types.Cache      as Key+import Hpaste.View.Activity    (page)++import Control.Monad.Env       (env)+import Snap.App++-- | Display commit history.+handle :: HPCtrl ()+handle = do+  html <- cache Key.Activity $ do+    uri <- env $ configCommits . controllerStateConfig+    repourl <- env $ configRepoURL . controllerStateConfig+    commits <- model $ getCommits uri+    return $ Just $ page repourl commits+  maybe (return ()) outputText html
+ src/Hpaste/Controller/Admin.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++-- | Report controller.++module Hpaste.Controller.Admin+  (withAuth)+  where++import           Hpaste.Controller.Cache (resetCache)+import           Hpaste.Model.Paste   (getPasteById,deletePaste)+import           Hpaste.Model.Report+import           Hpaste.Types+import           Hpaste.Types.Cache      as Key+import           Hpaste.View.Report+import qualified Hpaste.View.Thanks   as Thanks++import           Control.Applicative+import           Control.Monad.Reader+import           Data.ByteString.UTF8 (toString)+import           Data.Maybe+import           Data.Monoid.Operator ((++))+import           Data.Text            (unpack)+import           Prelude              hiding ((++))+import           Safe+import           Snap.App+import           Text.Blaze.Html5     as H hiding (output,map,body)+import           Text.Formlet++-- | Do something with authority.+withAuth :: (String -> HPCtrl ()) -> HPCtrl ()+withAuth m = do+  key <- fmap (fmap toString) $ getParam "key"+  realkey <- asks (configKey . controllerStateConfig)+  case key of+    Just k | k == realkey -> m k+    _ -> goHome
+ src/Hpaste/Controller/Browse.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Browse page controller.++module Hpaste.Controller.Browse+  (handle)+  where++import Hpaste.Types+import Hpaste.Model.Channel  (getChannels)+import Hpaste.Model.Language (getLanguages)+import Hpaste.Model.Paste    (getPaginatedPastes,countPublicPastes)+import Hpaste.View.Browse    (page)++import Text.Blaze.Pagination+import Snap.App++-- | Browse all pastes.+handle :: HPCtrl ()+handle = do+  pn <- getPagination "pastes"+  author <- getStringMaybe "author"+  (pn',pastes) <- model $ getPaginatedPastes author (pnPn pn)+  chans <- model getChannels+  langs <- model getLanguages+  output $ page pn { pnPn = pn' } chans langs pastes author
+ src/Hpaste/Controller/Cache.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}++-- | HTML caching.++module Hpaste.Controller.Cache+       (newCache+       ,cache+       ,cacheIf+       ,resetCache+       ,resetCacheModel)+       where+++import           Hpaste.Types.Cache+import           Hpaste.Types.Config++import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO         (io)+import           Control.Monad.Reader     (asks)+import qualified Data.Map                 as M+import           Data.Text.Lazy           (Text)+import qualified Data.Text.Lazy.IO as T+import           Snap.App.Types+import           System.Directory+import           Text.Blaze.Html5         (Html)+import           Text.Blaze.Renderer.Text (renderHtml)++-- | Create a new cache.+newCache :: IO Cache+newCache = do+  var <- newMVar M.empty+  return $ Cache var++-- | Cache conditionally.+cacheIf :: Bool -> Key -> Controller Config s (Maybe Html) -> Controller Config s (Maybe Text)+cacheIf pred key generate =+  if pred+     then cache key generate+     else fmap (fmap renderHtml) generate++-- | Generate and save into the cache, or retrieve existing from the+-- | cache.+cache :: Key -> Controller Config s (Maybe Html) -> Controller Config s (Maybe Text)+cache key generate = do+  tmpdir <- asks (configCacheDir . controllerStateConfig)+  let cachePath = tmpdir ++ "/" ++ keyToString key+  exists <- io $ doesFileExist cachePath+  if exists+     then do text <- io $ T.readFile cachePath+     	     return (Just text)+     else do text <- fmap (fmap renderHtml) generate+     	     case text of+	       Just text' -> do io $ T.writeFile cachePath text'+	       	    	        return text+               Nothing -> return text++-- | Reset an item in the cache.+resetCache :: Key -> Controller Config s ()+resetCache key = do+  tmpdir <- asks (configCacheDir . controllerStateConfig)+  io $ do+   let cachePath = tmpdir ++ "/" ++ keyToString key+   exists <- io $ doesFileExist cachePath+   when exists $ removeFile cachePath++-- | Reset an item in the cache.+resetCacheModel :: Key -> Model Config s ()+resetCacheModel key = do+  tmpdir <- asks (configCacheDir . modelStateConfig)+  io $ do+   let cachePath = tmpdir ++ "/" ++ keyToString key+   exists <- io $ doesFileExist cachePath+   when exists $ removeFile cachePath++keyToString :: Key -> String+keyToString Home = "home.html"+keyToString Activity = "activity.html"+keyToString (Paste i) = "paste-" ++ show i ++ ".html"+keyToString (Revision i) = "revision-" ++ show i ++ ".html"
+ src/Hpaste/Controller/Diff.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Diff page controller.++module Hpaste.Controller.Diff+  (handle)+  where++import Hpaste.Types+import Hpaste.Controller.Paste (withPasteKey)+import Hpaste.View.Diff        (page)++import Snap.App++-- | Diff one paste with another.+handle :: HPCtrl ()+handle = do+  withPasteKey "this" $ \this ->+    withPasteKey "that" $ \that ->+      output $ page this that
+ src/Hpaste/Controller/Home.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Home page controller.++module Hpaste.Controller.Home+  (handle)+  where++import Hpaste.Types+import Hpaste.Controller.Cache (cacheIf)+import Hpaste.Controller.Paste (pasteForm)+import Hpaste.Model.Channel    (getChannels)+import Hpaste.Model.Language   (getLanguages)+import Hpaste.Model.Paste      (getLatestPastes)+import Hpaste.Types.Cache      as Key+import Hpaste.View.Home        (page)++import Data.Maybe+import Snap.App++-- | Handle the home page, display a simple list and paste form.+handle :: Bool -> HPCtrl ()+handle spam = do+  html <- cacheIf (not spam) Key.Home $ do+    pastes <- model $ getLatestPastes+    chans <- model $ getChannels+    langs <- model $ getLanguages+    form <- pasteForm chans langs Nothing Nothing Nothing+    uri <- getMyURI+    return $ Just $ page uri chans langs pastes form spam+  maybe (return ()) outputText html
+ src/Hpaste/Controller/Irclogs.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Irclogs page controller.++module Hpaste.Controller.Irclogs+  (handle)+  where++import Hpaste.Controller+import Hpaste.Model.Irclogs+import Hpaste.Types+import Hpaste.View.Irclogs  (page)++import Data.String.ToString+import Data.String+import Snap.Types+import Safe++handle :: Controller ()+handle = do+  channel <- get "channel"+  date <- get "date"+  time <- get "timestamp"+  pasteid <- getMaybe "paste"+  logs <- getNarrowedLogs channel date time+  output $ page channel date time logs pasteid++  where get key = do+          value <- fmap (fmap toString) $ getParam (fromString key)+          case value of+            Nothing -> error $ "Missing parameter: " ++ key+            Just value -> return value+        getMaybe key = fmap ((>>= readMay) . fmap toString) $ getParam (fromString key)
+ src/Hpaste/Controller/New.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Create new paste controller.++module Hpaste.Controller.New+  (handle,NewStyle(..))+  where++import Hpaste.Types+import Hpaste.Controller.Paste (pasteForm,getPasteId)+import Hpaste.Model.Channel    (getChannels)+import Hpaste.Model.Language   (getLanguages)+import Hpaste.Model.Paste      (getPasteById)+import Hpaste.View.Annotate    as Annotate (page)+import Hpaste.View.Edit        as Edit (page)+import Hpaste.View.New         as New (page)++import Control.Applicative+import Data.Text.Encoding      (decodeUtf8)+import Snap.App++data NewStyle = NewPaste | AnnotatePaste | EditPaste+ deriving Eq++-- | Make a new paste.+handle :: NewStyle -> HPCtrl ()+handle style = do+  chans <- model $ getChannels+  langs <- model $ getLanguages+  defChan <- fmap decodeUtf8 <$> getParam "channel"+  pid <- if style == NewPaste then return Nothing else getPasteId+  case pid of+    Just pid -> do+      paste <- model $ getPasteById pid+      let apaste | style == AnnotatePaste = paste+      	  	 | otherwise = Nothing+      let epaste | style == EditPaste = paste+      	  	 | otherwise = Nothing+      form <- pasteForm chans langs defChan apaste epaste+      justOrGoHome paste $ \paste -> do+        case style of+          AnnotatePaste -> output $ Annotate.page paste form+	  EditPaste     -> output $ Edit.page paste form+	  _ -> goHome+    Nothing -> do+      form <- pasteForm chans langs defChan Nothing Nothing+      output $ New.page form
+ src/Hpaste/Controller/Paste.hs view
@@ -0,0 +1,134 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Paste controller.++module Hpaste.Controller.Paste+  (handle+  ,pasteForm+  ,getPasteId+  ,getPasteIdKey+  ,withPasteKey)+  where++import Hpaste.Types+import Hpaste.Controller.Cache (cache,resetCache)+import Hpaste.Model.Channel    (getChannels)+import Hpaste.Model.Language   (getLanguages)+import Hpaste.Model.Paste+import Hpaste.Model.Spam+import Hpaste.Types.Cache      as Key+import Hpaste.View.Paste       (pasteFormlet,page)++import Control.Applicative+import Control.Monad           ((>=>))+import Control.Monad.IO+import Data.ByteString         (ByteString)+import Data.ByteString.UTF8    (toString)+import Data.Maybe+import Data.Monoid.Operator    ((++))+import Data.String             (fromString)+import Data.Text               (Text)+import Prelude                 hiding ((++))+import Safe+import Snap.App+import Text.Blaze.Html5        as H hiding (output)+import Text.Formlet++-- | Handle the paste page.+handle :: Bool -> HPCtrl ()+handle revision = do+  pid <- getPasteId+  justOrGoHome pid $ \(pid) -> do+      html <- cache (if revision then Key.Revision pid else Key.Paste pid) $ do+        getPrivate <- getParam "show_private"+        paste <- model $ if isJust getPrivate+	      	       	    then getPrivatePasteById (pid)+	      	       	    else getPasteById (pid)+        case paste of+          Nothing -> return Nothing+          Just paste -> do+            hints <- model $ getHints (pasteId paste)+            annotations <- model $ getAnnotations (pid)+            revisions <- model $ getRevisions (pid)+            ahints <- model $ mapM (getHints.pasteId) annotations+            rhints <- model $ mapM (getHints.pasteId) revisions+            chans <- model $ getChannels+            langs <- model $ getLanguages+            return $ Just $ page PastePage {+              ppChans       = chans+            , ppLangs       = langs+            , ppAnnotations = annotations+            , ppRevisions   = revisions+            , ppHints       = hints+            , ppPaste       = paste+            , ppAnnotationHints = ahints+            , ppRevisionsHints = rhints+	    , ppRevision = revision+            }+      justOrGoHome html outputText++-- | Control paste annotating / submission.+pasteForm :: [Channel] -> [Language] -> Maybe Text -> Maybe Paste -> Maybe Paste -> HPCtrl Html+pasteForm channels languages defChan annotatePaste editPaste = do+  params <- getParams+  submittedPrivate <- isJust <$> getParam "private"+  submittedPublic <- isJust <$> getParam "public"+  revisions <- maybe (return []) (model . getRevisions) (fmap pasteId (annotatePaste <|> editPaste))+  let formlet = PasteFormlet {+          pfSubmitted = submittedPrivate || submittedPublic+        , pfErrors    = []+        , pfParams    = params+        , pfChannels  = channels+        , pfLanguages = languages+        , pfDefChan   = defChan+        , pfAnnotatePaste = annotatePaste+        , pfEditPaste = editPaste+	, pfContent = fmap pastePaste (listToMaybe revisions)+        }+      (getValue,_) = pasteFormlet formlet+      value = formletValue getValue params+      errors = either id (const []) value+      (_,html) = pasteFormlet formlet { pfErrors = errors }+      val = either (const Nothing) Just $ value+  case val of+    Nothing -> return ()+    Just PasteSubmit{pasteSubmitSpamTrap=Just{}} -> goHome+    Just paste -> do+      spamrating <- model $ spamRating paste+      if spamrating >= spamMaxLevel+      	 then goSpamBlocked+	 else do+	    resetCache Key.Home+	    maybe (return ()) (resetCache . Key.Paste) $ pasteSubmitId paste+	    pid <- model $ createPaste languages channels paste spamrating submittedPublic+	    maybe (return ()) redirectToPaste pid+  return html++-- | Go back to the home page with a spam indication.+goSpamBlocked :: HPCtrl ()+goSpamBlocked = redirect "/spam"++-- | Redirect to the paste's page.+redirectToPaste :: PasteId -> HPCtrl ()+redirectToPaste (PasteId pid) =+  redirect $ "/" ++ fromString (show pid)++-- | Get the paste id.+getPasteId :: HPCtrl (Maybe PasteId)+getPasteId = (fmap toString >=> (fmap PasteId . readMay)) <$> getParam "id"++-- | Get the paste id by a key.+getPasteIdKey :: ByteString -> HPCtrl (Maybe PasteId)+getPasteIdKey key = (fmap toString >=> (fmap PasteId . readMay)) <$> getParam key++-- | With the+withPasteKey :: ByteString -> (Paste -> HPCtrl a) -> HPCtrl ()+withPasteKey key with = do+  pid <- getPasteIdKey key+  justOrGoHome pid $ \(pid ) -> do+    paste <- model $ getPasteById pid+    justOrGoHome paste $ \paste -> do+      _ <- with paste+      return ()
+ src/Hpaste/Controller/Raw.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Raw controller.++module Hpaste.Controller.Raw+  (handle)+  where++import Hpaste.Model.Paste   (getPasteById)+import Hpaste.Types++import Control.Applicative+import Data.ByteString.UTF8 (toString)+import Data.Maybe+import Data.Text.Lazy       (fromStrict)+import Prelude              hiding ((++))+import Safe+import Snap.App++-- | Handle the paste page.+handle :: HPCtrl ()+handle = do+  pid <- (>>= readMay) . fmap (toString) <$> getParam "id"+  case pid of+    Nothing -> goHome+    Just (pid :: Integer) -> do+      modifyResponse $ setContentType "text/plain; charset=UTF-8"+      paste <- model $ getPasteById (PasteId pid)+      maybe goHome (outputText . fromStrict . pastePaste) paste
+ src/Hpaste/Controller/Report.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++-- | Report controller.++module Hpaste.Controller.Report+  (handle+  ,handleDelete)+  where++import           Hpaste.Controller.Cache (resetCache)+import           Hpaste.Controller.Admin (withAuth)+import           Hpaste.Model.Paste   (getPasteById,deletePaste)+import           Hpaste.Model.Report+import           Hpaste.Types+import           Hpaste.Types.Cache      as Key+import           Hpaste.View.Report+import qualified Hpaste.View.Thanks   as Thanks++import           Control.Applicative+import           Control.Monad.Reader+import           Data.ByteString.UTF8 (toString)+import           Data.String+import           Data.Maybe+import           Data.Monoid.Operator ((++))+import           Data.Text            (unpack)+import           Prelude              hiding ((++))+import           Safe+import           Snap.App+import           Text.Blaze.Html5     as H hiding (output,map,body)+import           Text.Formlet++-- | Handle the report/delete page.+handle :: HPCtrl ()+handle = do+   pid <- (>>= readMay) . fmap (toString) <$> getParam "id"+   case pid of+     Nothing -> goHome+     Just (pid :: Integer) -> do+       paste <- model $ getPasteById (PasteId pid)+       (frm,val) <- exprForm+       case val of+	 Just comment -> do+	   _ <- model $ createReport ReportSubmit { rsPaste = PasteId pid+						  , rsComments = comment }+	   resetCache Key.Home+	   output $ Thanks.page "Reported" $+				"Thanks, your comments have " +++				"been reported to the administrator."+	 Nothing -> maybe goHome (output . page frm) paste++-- | Report form.+exprForm :: HPCtrl (Html,Maybe String)+exprForm = do+  params <- getParams+  submitted <- isJust <$> getParam "submit"+  let formlet = ReportFormlet {+          rfSubmitted = submitted+        , rfParams    = params+        }+      (getValue,_) = reportFormlet formlet+      value = formletValue getValue params+      (_,html) = reportFormlet formlet+      val = either (const Nothing) Just $ value+  return (html,fmap unpack val)++handleDelete :: HPCtrl ()+handleDelete =+  withAuth $ \_ -> do+    pid <- (>>= readMay) . fmap (toString) <$> getParam "id"+    case pid of+      Nothing -> goReport+      Just (pid :: Integer) -> do+	model $ deletePaste pid+	goReport++-- | Go back to the reported page.+goReport :: HPCtrl ()+goReport = withAuth $ \key -> redirect (fromString ("/reported?key=" ++ key))
+ src/Hpaste/Controller/Reported.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Reported page controller.++module Hpaste.Controller.Reported+  (handle)+  where++import Hpaste.Model.Report   (getSomeReports,countReports)+import Hpaste.Controller.Admin   (withAuth)+import Hpaste.Types+import Hpaste.View.Reported  (page)++import Text.Blaze.Pagination+import Data.Pagination+import Snap.App++-- | List the reported pastes.+handle :: HPCtrl ()+handle =+  withAuth $ \key -> do+    pn <- getPagination "reported"+    total <- model countReports+    reports <- model $ getSomeReports (pnPn pn)+    output $ page pn reports key
+ src/Hpaste/Controller/Script.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | JavaScript controller.++module Hpaste.Controller.Script+  (handle)+  where++import Hpaste.View.Script (script)++import Snap.Core          (modifyResponse,setContentType)+import Snap.App++handle :: Controller c s ()+handle = do+  modifyResponse $ setContentType "text/javascript"+  outputText $ script
+ src/Hpaste/Controller/Style.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Stylesheet controller.++module Hpaste.Controller.Style+  (handle)+  where++import Hpaste.Types+import Hpaste.View.Style (style)++import Snap.App++handle :: HPCtrl ()+handle = do+  modifyResponse $ setContentType "text/css"+  outputText $ style
+ src/Hpaste/Model/Activity.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Activity model.++module Hpaste.Model.Activity+  (getCommits)+  where++import Hpaste.Types++import Control.Monad.IO      (io)+import Data.Maybe            (mapMaybe)+import Data.Text.Lazy        (pack)+import Data.Time+import Network.Curl.Download+import Snap.App.Types+import System.Locale+import Text.Feed.Query++-- | Get commits of this project from a commit feed.+getCommits :: String -> Model c s [Commit]+getCommits uri = io $ do+  result <- openAsFeed uri+  case result of+    Left _ -> return []+    Right feed -> return $+      let items = getFeedItems feed+      in mapMaybe makeCommit items++  where makeCommit item = do+          title <- getItemTitle item+          datestr <- getItemDate item+          date <- parseDateString datestr+          link <- getItemLink item+          return $ Commit {+            commitTitle = pack $ title+          , commitContent = "" -- Getting content from atom does not work.+          , commitDate = date+          , commitLink = pack link+          }+        -- E.g. 2011-06-11T11:15:11-07:00+        parseDateString = parseTime defaultTimeLocale "%Y-%M-%dT%T%Z"
+ src/Hpaste/Model/Announcer.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | IRC announcer.++module Hpaste.Model.Announcer+       (newAnnouncer+       ,announce+       )+       where++import           Hpaste.Types.Announcer+import		 Control.Monad.Fix+import           Control.Concurrent+import qualified Control.Exception       as E+import           Control.Monad+import           Control.Monad.Env       (env)+import           Control.Monad.IO        (io)+import qualified Data.ByteString    as B+import           Data.Monoid.Operator    ((++))+import 		 Data.Char+import           Data.Text          (Text,pack,unpack)+import qualified Data.Text          as T+import           Data.Text.Encoding+import Data.Time+import qualified Data.Text.IO       as T+import           Network+import           Prelude                 hiding ((++))+import           Snap.App.Types+import           System.IO++-- | Start a thread and return a channel to it.+newAnnouncer :: AnnounceConfig -> IO Announcer+newAnnouncer config = do+  putStrLn "Connecting..."+  ans <- newChan+  let self = Announcer { annChan = ans, annConfig = config }+  _ <- forkIO $ announcer self (const (return ()))+  return self++-- | Run the announcer bot.+announcer ::  Announcer -> (Handle -> IO ()) -> IO ()+announcer self@Announcer{annConfig=config,annChan=ans} cont = do+  announcements <- getChanContents ans+  forM_ announcements $ \ann ->+    E.catch (sendIfNickExists config ann)+            (\(e::IOError) -> return ())++sendIfNickExists AnnounceConfig{..} (Announcement origin line) = do+  handle <- connectTo announceHost (PortNumber $ fromIntegral announcePort)+  hSetBuffering handle LineBuffering+  let send = B.hPutStrLn handle . encodeUtf8+  send $ "PASS " ++ pack announcePass+  send $ "USER " ++ pack announceUser ++ " * * *"+  send $ "NICK " ++ pack announceUser+  send $ "WHOIS :" ++ origin+  fix $ \loop -> do+    incoming <- T.hGetLine handle+    case T.takeWhile isDigit (T.drop 1 (T.dropWhile (/=' ') incoming)) of+      "311" -> send line+      "401" -> return ()+      _ -> loop++-- | Announce something to the IRC.+announce :: Announcer -> Text -> Text -> Text -> IO ()+announce Announcer{annChan=chan} nick channel line = do+  io $ writeChan chan $ Announcement nick ("PRIVMSG " ++ channel ++ " :" ++ line)
+ src/Hpaste/Model/Channel.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Channel model.++module Hpaste.Model.Channel+  (getChannels)+  where++import Hpaste.Types++import Snap.App++-- | Get the channels.+getChannels :: Model c s [Channel]+getChannels =+  queryNoParams ["SELECT *"+                ,"FROM channel"]
+ src/Hpaste/Model/Irclogs.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++module Hpaste.Model.Irclogs where++import           Hpaste.Types++import           Control.Applicative+import           Control.Arrow+import           Control.Monad.IO+import           Control.Monad.Reader+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as S+import           Data.Char+import           Data.Either+import           Data.List                (find)+import           Data.List.Utils+import           Data.Maybe+import           Data.Monoid.Operator     ((++))+import           Data.Text                (Text)+import qualified Data.Text                as T+import           Data.Text.Encoding+import           Data.Text.Encoding.Error (lenientDecode)+import           Data.Time+import           Network.Curl.Download+import           Prelude                  hiding ((++))+import           System.Directory+import           System.FilePath+import           System.Locale++-- | Get IRC logs for the given channel narrowed down to the given date/time.+getNarrowedLogs :: String -- ^ Channel name.+                -> String -- ^ Date.+                -> String -- ^ Time.+                -> Controller (Either String [Text])+getNarrowedLogs channel year time = do+  case parseIrcDate year of+    Nothing -> return $ Left $ "Unable to parse year: " ++ year+    Just date -> do+      days <- mapM (getLogs channel . showIrcDate) [addDays (-1) date,date,addDays 1 date]+      let events = concat (rights days)+      return (Right (fromMaybe events+                               (narrowBy (T.isPrefixOf datetime) events <|>+                                narrowBy (T.isPrefixOf dateminute) events <|>+                                narrowBy (T.isPrefixOf datehour) events <|>+                                narrowBy (T.isPrefixOf datestr) events <|>+                                narrowBy (T.isPrefixOf dateday) events)))+  +  where narrowBy pred events =+          case find pred (filter crap events) of+            Nothing -> Nothing+            Just _res -> Just $ narrow count pred (filter crap events)+        count = 50+        datetime   = T.pack $ year ++ "-" ++ replace "-" ":" time+        dateminute = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 2 . reverse $ time)+        datehour   = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 5 . reverse $ time)+        datestr    = T.pack $ year ++ "-"+        dateday    = T.pack $ reverse . drop 2 . reverse $ year+        crap = not . T.isPrefixOf " --- " . T.dropWhile (not . isSpace)++-- | Narrow to surrounding predicate.+narrow :: Int -> (a -> Bool) -> [a] -> [a]+narrow n f = uncurry (++) . (reverse . take n . reverse *** take n) . break f++-- | Get IRC logs for the given channel and date.+getLogs :: String -- ^ Channel name.+        -> String -- ^ Date.+        -> Controller (Either String [Text])+getLogs channel year = do+  dir <- asks $ configIrcDir . controllerStateConfig+  io $ do+    now <- fmap (showIrcDate . utctDay) getCurrentTime+    result <- openURICached (year == now) (file dir) uri+    case result of+      Left err    -> return $ Left $ uri ++ ": " ++ err+      Right bytes -> return $ Right (map addYear (T.lines (decodeUtf8With lenientDecode bytes)))++  where uri = "http://tunes.org/~nef/logs/" ++ channel ++ "/" ++ yearStr+        file dir = dir </> channel ++ "-" ++ yearStr+        yearStr = replace "-" "." (drop 2 year)+        addYear line = T.pack year ++ "-" ++ line++-- | Open the URI and cache the result.+openURICached :: Bool -> FilePath -> String -> IO (Either String ByteString)+openURICached noCache path url = do+  exists <- doesFileExist path+  if exists && not noCache+     then fmap Right $ S.readFile path+     else do result <- openURI url+             case result of+               Right bytes -> S.writeFile path bytes+               _           -> return ()+             return result++-- | Parse an IRC date string into a date.+parseIrcDate :: String -> Maybe Day+parseIrcDate = parseTime defaultTimeLocale "%Y-%m-%d"++-- | Show a date to an IRC date format.+showIrcDate :: Day -> String+showIrcDate = formatTime defaultTimeLocale "%Y-%m-%d"++-- | Show a date to an IRC date format.+showIrcDateTime :: UTCTime -> String+showIrcDateTime =+  formatTime defaultTimeLocale "%Y-%m-%d/%H-%M-%S" . addUTCTime ((40*60)+((-9)*60*60))
+ src/Hpaste/Model/Language.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Language model.++module Hpaste.Model.Language+  (getLanguages)+  where++import Hpaste.Types++import Snap.App++-- | Get the languages.+getLanguages :: Model c s [Language]+getLanguages =+  queryNoParams ["SELECT id,name,title"+                ,"FROM language"+                ,"WHERE visible"+                ,"ORDER BY ordinal,title ASC"]
+ src/Hpaste/Model/Paste.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}++-- | Paste model.++module Hpaste.Model.Paste+  (getLatestPastes+  ,getPasteById+  ,getPrivatePasteById+  ,createOrUpdate+  ,deletePaste+  ,createPaste+  ,getAnnotations+  ,getRevisions+  ,getPaginatedPastes+  ,countPublicPastes+  ,generateHints+  ,getHints+  ,validNick)+  where++import Hpaste.Types+import Hpaste.Model.Announcer+import Hpaste.Model.Spam++import Data.Pagination+import Control.Applicative    ((<$>),(<|>))+import Control.Exception as E+import Control.Monad+import Control.Monad.Env+import Control.Monad.IO+import Data.Char+import Data.List              (find,intercalate)+import Data.Maybe+import Data.Monoid.Operator   ((++))+import Data.Text              (Text,unpack,pack)+import qualified Data.Text              as T+import Data.Text.IO           as T (writeFile)+import Data.Text.Lazy         (fromStrict)+import Language.Haskell.HLint+import Prelude                hiding ((++))+import Snap.App+import System.Directory+import System.FilePath++deletePaste :: Integer -> HPModel ()+deletePaste pid = void (exec ["DELETE FROM paste WHERE id = ?"] (Only pid))++-- | Count public pastes.+countPublicPastes :: Maybe String -> HPModel Integer+countPublicPastes mauthor = do+  rows <- single ["SELECT COUNT(*)"+                 ,"FROM public_toplevel_paste"+		 ,"WHERE (? IS NULL) OR (author = ?) AND spamrating < ?"]+		 (mauthor,mauthor,spamMinLevel)+  return $ fromMaybe 0 rows++-- | Get the latest pastes.+getLatestPastes :: HPModel [Paste]+getLatestPastes =+  query ["SELECT ",pasteFields+	,"FROM public_toplevel_paste"+	,"WHERE spamrating < ?"+	,"ORDER BY created DESC"+	,"LIMIT 20"]+       (Only spamMinLevel)++-- | Get some paginated pastes.+getPaginatedPastes :: Maybe String -> Pagination -> HPModel (Pagination,[Paste])+getPaginatedPastes mauthor pn@Pagination{..} = do+  total <- countPublicPastes mauthor+  rows <- query ["SELECT",pasteFields+		,"FROM public_toplevel_paste"+		,"WHERE (? IS NULL) OR (author = ?) AND spamrating < ?"+		,"ORDER BY created DESC"+		,"OFFSET " ++ show (max 0 (pnCurrentPage - 1) * pnPerPage)+		,"LIMIT " ++ show pnPerPage]+		(mauthor,mauthor,spamMinLevel)+  return (pn { pnTotal = total },rows)++-- | Get a paste by its id.+getPasteById :: PasteId -> HPModel (Maybe Paste)+getPasteById pid =+  listToMaybe <$> query ["SELECT ",pasteFields+                        ,"FROM public_paste"+                        ,"WHERE id = ?"]+                        (Only pid)++-- | Get a private paste by its id, regardless of any status.+getPrivatePasteById :: PasteId -> HPModel (Maybe Paste)+getPrivatePasteById pid =+  listToMaybe <$> query ["SELECT",pasteFields+                        ,"FROM private_paste"+                        ,"WHERE id = ?"]+                        (Only pid)++-- | Get annotations of a paste.+getAnnotations :: PasteId -> HPModel [Paste]+getAnnotations pid =+  query ["SELECT",pasteFields+        ,"FROM public_paste"+        ,"WHERE annotation_of = ?"+        ,"ORDER BY created ASC"]+        (Only pid)++-- | Get revisions of a paste.+getRevisions :: PasteId -> HPModel [Paste]+getRevisions pid = do+  query ["SELECT",pasteFields+        ,"FROM public_paste"+        ,"WHERE revision_of = ? or id = ?"+        ,"ORDER BY created DESC"]+        (pid,pid)++-- | Create a paste, or update an existing one.+createOrUpdate :: [Language] -> [Channel] -> PasteSubmit -> Integer -> Bool -> HPModel (Maybe PasteId)+createOrUpdate langs chans paste@PasteSubmit{..} spamrating public = do+  case pasteSubmitId of+    Nothing  -> createPaste langs chans paste spamrating public+    Just pid -> do updatePaste pid paste+                   return $ Just pid++-- | Create a new paste (possibly annotating an existing one).+createPaste :: [Language] -> [Channel] -> PasteSubmit -> Integer -> Bool -> HPModel (Maybe PasteId)+createPaste langs chans ps@PasteSubmit{..} spamrating public = do+  pid <- generatePasteId public+  res <- single ["INSERT INTO paste"+                ,"(id,title,author,content,channel,language,annotation_of,revision_of,spamrating,public)"+                ,"VALUES"+                ,"(?,?,?,?,?,?,?,?,?,?)"+                ,"returning id"]+                (pid,pasteSubmitTitle,pasteSubmitAuthor,pasteSubmitPaste+                ,pasteSubmitChannel,pasteSubmitLanguage,ann_pid,rev_pid,spamrating,public)+  when (lang == Just "haskell") $ just res $ createHints ps+  just (pasteSubmitChannel >>= lookupChan) $ \chan ->+    just res $ \pid -> do+      when (spamrating < spamMinLevel) $+        announcePaste pasteSubmitType (channelName chan) ps pid+  return (pasteSubmitId <|> res)++  where lookupChan cid = find ((==cid).channelId) chans+        lookupLang lid = find ((==lid).languageId) langs+        lang = pasteSubmitLanguage >>= (fmap languageName . lookupLang)+        just j m = maybe (return ()) m j+        ann_pid = case pasteSubmitType of AnnotationOf pid -> Just pid; _ -> Nothing+        rev_pid = case pasteSubmitType of RevisionOf pid -> Just pid; _ -> Nothing++-- | Generate a fresh unique paste id.+generatePasteId :: Bool -> HPModel PasteId+generatePasteId public = do+  result <- if public+               then single ["SELECT NEXTVAL('paste_id_seq')"] ()+               else single ["SELECT (RANDOM()*9223372036854775807) :: BIGINT"] ()+  case result of+    Just pid@(PasteId i) -> do+      result <- single ["SELECT TRUE FROM paste WHERE id = ?"] (Only pid)+      case result :: Maybe PasteId of+        Just pid -> generatePasteId public+        _        -> return pid++-- | Create the hints for a paste.+createHints :: PasteSubmit -> PasteId -> HPModel ()+createHints ps pid = do+  hints <- generateHintsForPaste ps pid+  forM_ hints $ \hint ->+    exec ["INSERT INTO hint"+         ,"(paste,type,content)"+         ,"VALUES"+         ,"(?,?,?)"]+         (pid+         ,suggestionSeverity hint+         ,show hint)++-- | Announce the paste.+announcePaste :: PasteType -> Text -> PasteSubmit -> PasteId -> HPModel ()+announcePaste ptype channel PasteSubmit{..} pid = do+  conf <- env modelStateConfig+  verb <- getVerb+  unless (seemsLikeSpam pasteSubmitTitle || seemsLikeSpam pasteSubmitAuthor) $ do+    announcer <- env modelStateAnns+    io $ announce announcer pasteSubmitAuthor channel $ do+      nick ++ " " ++ verb ++ " “" ++ pasteSubmitTitle ++ "” at " ++ link conf+  where nick | validNick (unpack pasteSubmitAuthor) = pasteSubmitAuthor+             | otherwise = "“" ++ pasteSubmitAuthor ++ "”"+        link Config{..} = "http://" ++ pack configDomain ++ "/" ++ pid'+        pid' = case ptype of+	         NormalPaste -> showPid pid+                 AnnotationOf apid -> showPid apid ++ "#a" ++ showPid pid+                 RevisionOf apid -> showPid apid+        getVerb = case ptype of+          NormalPaste -> return $ "pasted"+          AnnotationOf pid -> do+            paste <- getPasteById pid+	    return $ case paste of+	      Just Paste{..} -> "annotated “" ++ pasteTitle ++ "” with"+              Nothing -> "annotated a paste with"+          RevisionOf pid -> do+            paste <- getPasteById pid+	    return $ case paste of+	      Just Paste{..} -> "revised “" ++ pasteTitle ++ "”:"+              Nothing -> "revised a paste:"+        showPid (PasteId p) = pack $ show $ (p :: Integer)+        seemsLikeSpam = T.isInfixOf "http://"++-- | Is a nickname valid? Digit/letter or one of these: -_/\\;()[]{}?`'+validNick :: String -> Bool+validNick s = first && all ok s && length s > 0 where+  ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'"+  first = all (\c -> isDigit c || isLetter c) $ take 1 s++-- | Get hints for a Haskell paste from hlint.+generateHintsForPaste :: PasteSubmit -> PasteId -> HPModel [Suggestion]+generateHintsForPaste PasteSubmit{..} (PasteId pid) = io $+  E.catch (generateHints (show pid) pasteSubmitPaste)+          (\SomeException{} -> return [])++-- | Get hints for a Haskell paste from hlint.+generateHints :: FilePath -> Text -> IO [Suggestion]+generateHints pid contents = io $ do+  tmpdir <- getTemporaryDirectory+  let tmp = tmpdir </> pid ++ ".hs"+  exists <- doesFileExist tmp+  unless exists $ T.writeFile tmp $ contents+  !hints <- hlint [tmp,"--quiet","--ignore=Parse error"]+  removeFile tmp+  return hints++getHints :: PasteId -> HPModel [Hint]+getHints pid =+  query ["SELECT type,content"+        ,"FROM hint"+        ,"WHERE paste = ?"]+        (Only pid)++-- | Update an existing paste.+updatePaste :: PasteId -> PasteSubmit -> HPModel ()+updatePaste pid PasteSubmit{..} = do+  _ <- exec (["UPDATE paste"+             ,"SET"]+             +++             [intercalate ", " (map set (words fields))]+             +++             ["WHERE id = ?"])+            (pasteSubmitTitle+            ,pasteSubmitAuthor+            ,pasteSubmitPaste+            ,pasteSubmitLanguage+            ,pasteSubmitChannel+            ,pid)+  return ()++    where fields = "title author content language channel"+          set key = unwords [key,"=","?"]++pasteFields = "id,title,content,author,created,views,language,channel,annotation_of,revision_of"
+ src/Hpaste/Model/Report.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Report model.++module Hpaste.Model.Report+ (getSomeReports,createReport,countReports)+  where++import           Hpaste.Types+import           Hpaste.Controller.Cache+import           Hpaste.Types.Cache as Key++import           Control.Monad++import           Control.Monad.Env+import           Control.Monad.IO+import           Data.Pagination+import           Data.Maybe+import           Data.Monoid.Operator ((++))+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import           Network.Mail.Mime+import           Prelude              hiding ((++))+import           Snap.App++-- | Get some paginated reports.+getSomeReports :: Pagination -> Model c s [Report]+getSomeReports Pagination{..} =+  queryNoParams ["SELECT created,paste,comments"+                ,"FROM report"+                ,"ORDER BY id DESC"+                ,"OFFSET " ++ show (max 0 (pnCurrentPage - 1) * pnPerPage)+                ,"LIMIT " ++ show pnPerPage]++-- | Count reports.+countReports :: Model c s Integer+countReports = do+  rows <- singleNoParams ["SELECT COUNT(*)"+                         ,"FROM report"]+  return $ fromMaybe 0 rows++-- | Create a new report.+createReport :: ReportSubmit -> Model Config s (Maybe ReportId)+createReport rs@ReportSubmit{..} = do+  res <- single ["INSERT INTO report"+                ,"(paste,comments)"+                ,"VALUES"+                ,"(?,?)"+                ,"returning id"]+                (rsPaste,rsComments)+  _ <- exec ["UPDATE paste"+       	    ,"SET public = false"+	    ,"WHERE id = ?"]+	    (Only rsPaste)+  let reset pid = do+        resetCacheModel (Key.Paste pid)+        resetCacheModel (Key.Revision pid)+  reset rsPaste+  sendReport rs+  return res++sendReport :: ReportSubmit -> Model Config s ()+sendReport ReportSubmit{..} = do+  conf <- env modelStateConfig+  m <- io $ simpleMail (configAdmin conf)+		       (configSiteAddy conf)+		       (T.pack ("Paste reported: #" ++ show rsPaste))+		       (LT.pack body)+		       (LT.pack body)+		       []+  io $ renderSendMail m++  where body =+  	  "Paste " ++ show rsPaste ++ "\n\n" +++	  "http://hpaste.org/" ++ show rsPaste ++ "?show_private=true" +++	  "\n\n" +++	  rsComments
+ src/Hpaste/Model/Spam.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Spam detection.++module Hpaste.Model.Spam where++import Hpaste.Types+import Data.Monoid+import Data.Text (Text)+import Control.Monad.IO+import Control.Monad.Env+import Control.Monad+import qualified Data.Text.Lazy as LT+import qualified Data.Text as T+import System.Process hiding (env)+import Snap.App+import Network.Mail.Mime++-- | Get a spam rating for the given potential paste.+spamRating :: PasteSubmit -> Model Config s Integer+spamRating ps = do+  score <- if definitelySpam ps+     then return 100+     else fmap (weighted ps) (io (getRating mail))+  when (score > spamMaxLevel) $ reportBadScore ps score+  return score++  where mail = unlines ["from: noreply@hpaste.org"+                       ,"subject: " ++ T.unpack (pasteSubmitTitle ps)+		       ,""+		       ,T.unpack (pasteSubmitPaste ps)]++reportBadScore PasteSubmit{..} score = do+  conf <- env modelStateConfig+  m <- io $ simpleMail (configAdmin conf)+		       (configSiteAddy conf)+		       ("Paste marked as spam: " <> pasteSubmitTitle)+		       body+		       body+		       []+  io $ renderSendMail m++  where body = LT.pack $+  	  "Paste '" ++ T.unpack pasteSubmitTitle ++ "' by " ++ T.unpack pasteSubmitAuthor ++ " " +++	  "has rating " ++ show score ++ " with content: " +++	  T.unpack pasteSubmitPaste++-- | Get the rating from spam assassin.+getRating :: String -> IO Integer+getRating mail = do +  (_,err,_) <- readProcessWithExitCode "spamc" ["-c"] mail+  return $ case reads err of+    [(n :: Double,_)]     -> round (n*10)+    _                     -> 50++-- | Mark something as definitely spam.+definitelySpam :: PasteSubmit -> Bool+definitelySpam ps =+  T.isInfixOf "http://" (pasteSubmitTitle ps) ||+  T.isInfixOf "http://" (pasteSubmitAuthor ps) ||+  T.isInfixOf "stooorage" (allText ps) ||+  T.isInfixOf "http://fur.ly" (allText ps) ||+  T.isInfixOf "anekahosting.com" (allText ps) ||+  justUrl +   where justUrl = +   	   (T.isPrefixOf "http://" paste ||+   	    T.isPrefixOf "https://" paste) &&+	    lineCount == 1+	 lineCount = length (filter (not . T.null) +                                    (map T.strip+                                         (T.lines paste)))+         paste = T.strip (pasteSubmitPaste ps)++-- | Multiple the rating by weights specific to hpaste.+weighted :: PasteSubmit -> Integer -> Integer+weighted ps n = foldr ($) n weights where+  weights = [if T.isInfixOf "http://" text || T.isInfixOf "https://" text+  	    	then (+ (20 * fromIntegral (T.count "http://" text + T.count "https://" text))) else id+            ,if pasteSubmitAuthor ps == "Anonymous Coward" || pasteSubmitAuthor ps == "Anonymous"+	    	then (+20) else id+            ]+  text = allText ps++-- | Get the text of the paste.+allText :: PasteSubmit -> Text+allText PasteSubmit{..} = T.toLower $ pasteSubmitTitle <> " " <> pasteSubmitPaste++-- | Maximum level, anything equal or above this is treated as definitely spam, ignored.+spamMaxLevel = 100++-- | Minimum level, anything equal or above this is treated as possibly spam, accepted but not listed.+spamMinLevel = 60
+ src/Hpaste/Types.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS -Wall -fno-warn-orphans #-}++-- | All types.++module Hpaste.Types+       (module Hpaste.Types.Paste+       ,module Hpaste.Types.Channel+       ,module Hpaste.Types.Language+       ,module Hpaste.Types.Page+       ,module Hpaste.Types.Newtypes+       ,module Hpaste.Types.Config+       ,module Hpaste.Types.Activity+       ,module Hpaste.Types.Stepeval+       ,module Hpaste.Types.Report+       ,HPState+       ,HPCtrl+       ,HPModel)+       where++import Hpaste.Types.Paste+import Hpaste.Types.Channel+import Hpaste.Types.Language+import Hpaste.Types.Page+import Hpaste.Types.Newtypes+import Hpaste.Types.Config+import Hpaste.Types.Activity+import Hpaste.Types.Stepeval+import Hpaste.Types.Report+import Hpaste.Types.Announcer (Announcer)++import Control.Concurrent (Chan)+import Control.Monad.Env+import Control.Monad.IO+import Control.Monad.Reader+import Data.Text.Lazy (Text)+import Snap.App.Types++type HPState = Announcer+type HPCtrl = Controller Config HPState+type HPModel = Model Config HPState++instance AppLiftModel Config HPState where+  liftModel action = do+    conn <- env controllerStateConn+    anns <- env controllerState+    conf <- env controllerStateConfig+    let state = ModelState conn anns conf+    io $ runReaderT (runModel action) state
+ src/Hpaste/Types/Activity.hs view
@@ -0,0 +1,11 @@+module Hpaste.Types.Activity where++import Data.Text.Lazy (Text)+import Data.Time      (UTCTime)++data Commit = Commit {+  commitTitle :: Text+ ,commitContent :: Text+ ,commitDate :: UTCTime+ ,commitLink :: Text+} deriving Show
+ src/Hpaste/Types/Announcer.hs view
@@ -0,0 +1,24 @@+module Hpaste.Types.Announcer where++import Control.Concurrent+import Data.Text++-- | Announcer configuration.+data AnnounceConfig = AnnounceConfig {+    announceUser :: String+  , announcePass :: String+  , announceHost :: String+  , announcePort :: Int+} deriving (Show)++-- | An announcer.+data Announcer = Announcer+  { annChan :: Chan Announcement+  , annConfig :: AnnounceConfig+  }++-- | An annoucement.+data Announcement = Announcement+  { annFrom :: Text+  , annContent :: Text+  }
+ src/Hpaste/Types/Cache.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS -Wall #-}++-- | HTML caching types.++module Hpaste.Types.Cache+       (Key(..)+       ,Cache(..))+       where++import Control.Concurrent.MVar (MVar)+import Data.Map                (Map)+import Data.Text.Lazy          (Text)+import Hpaste.Types.Newtypes++data Key =+    Home+  | Paste PasteId+  | Revision PasteId+  | Activity+    deriving (Eq,Ord)++data Cache =+  Cache {+    cacheMap :: MVar (Map Key Text)+  }
+ src/Hpaste/Types/Channel.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS -Wall #-}++-- | The channel type.++module Hpaste.Types.Channel+       (Channel(..))+       where++import Hpaste.Types.Newtypes+import Control.Applicative+import Data.Text                               (Text)+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow++data Channel = Channel {+  channelId   :: ChannelId+ ,channelName :: Text+} deriving Show++instance FromRow Channel where+  fromRow = Channel <$> field+		    <*> field
+ src/Hpaste/Types/Config.hs view
@@ -0,0 +1,30 @@+-- | Site-wide configuration.++module Hpaste.Types.Config+       (Config(..)+       ,AnnounceConfig(..))+       where++import Database.PostgreSQL.Simple (ConnectInfo)+import Network.Mail.Mime (Address)+import Snap.App.Types++import Hpaste.Types.Announcer++-- | Site-wide configuration.+data Config = Config {+    configAnnounce        :: AnnounceConfig+  , configPostgres        :: ConnectInfo+  , configDomain          :: String+  , configCommits         :: String+  , configRepoURL         :: String+  , configIrcDir          :: FilePath+  , configAdmin           :: Address+  , configSiteAddy        :: Address+  , configCacheDir        :: FilePath+  , configKey             :: String+  }++instance AppConfig Config where+  getConfigDomain = configDomain+
+ src/Hpaste/Types/Language.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS -Wall #-}++-- | The language type.++module Hpaste.Types.Language+       (Language(..))+       where++import Hpaste.Types.Newtypes+import Control.Applicative+import Data.Text                               (Text)+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow++data Language = Language {+  languageId    :: LanguageId+ ,languageName  :: Text+ ,languageTitle :: Text+} deriving Show++instance FromRow Language where+  fromRow = Language <$> field+  	    	     <*> field+		     <*> field
+ src/Hpaste/Types/Newtypes.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Newtypes; foreign keys and such.++module Hpaste.Types.Newtypes+       (PasteId(..)+       ,ChannelId(..)+       ,LanguageId(..)+       ,ReportId(..))+       where++import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField++newtype PasteId = PasteId Integer+  deriving (Eq,FromField,ToField,Ord)++instance Show PasteId where show (PasteId pid) = show pid++newtype ReportId = ReportId Integer+  deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField)++instance Show ReportId where show (ReportId pid) = show pid++newtype ChannelId = ChannelId Integer+  deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField)++instance Show ChannelId where show (ChannelId pid) = show pid++newtype LanguageId = LanguageId Integer+  deriving (Integral,Real,Num,Ord,Eq,Enum,FromField,ToField)++instance Show LanguageId where show (LanguageId pid) = show pid
+ src/Hpaste/Types/Page.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The page type.++module Hpaste.Types.Page+       (Page(..))+       where++import Data.Text  (Text)+import Text.Blaze (Markup)++-- | A page to be rendered in a layout.+data Page = Page {+    pageTitle :: Text+  , pageBody :: Markup+  , pageName :: Text+  }
+ src/Hpaste/Types/Paste.hs view
@@ -0,0 +1,166 @@+{-# OPTIONS -Wall -fno-warn-orphans #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The paste type.++module Hpaste.Types.Paste+       (Paste(..)+       ,PasteType(..)+       ,PasteSubmit(..)+       ,PasteFormlet(..)+       ,ExprFormlet(..)+       ,PastePage(..)+       ,StepsPage(..)+       ,Hint(..)+       ,ReportFormlet(..)+       ,ReportSubmit(..))+       where++import Hpaste.Types.Newtypes+import Hpaste.Types.Language+import Hpaste.Types.Channel+import Control.Applicative+import Blaze.ByteString.Builder                (toByteString)+import Blaze.ByteString.Builder.Char.Utf8      as Utf8 (fromString)+import Data.Text                               (Text,pack)+import Data.Time                               (UTCTime,zonedTimeToUTC)+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField+import Language.Haskell.HLint                  (Severity)+import Snap.Core+import Text.Blaze                              (ToMarkup(..),toMarkup)+import Text.Blaze.Html5                        (Markup)++-- | A paste.+data Paste = Paste {+   pasteId       :: PasteId+  ,pasteTitle    :: Text+  ,pasteDate     :: UTCTime+  ,pasteAuthor   :: Text+  ,pasteLanguage :: Maybe LanguageId+  ,pasteChannel  :: Maybe ChannelId+  ,pastePaste    :: Text+  ,pasteViews    :: Integer+  ,pasteType     :: PasteType+} deriving Show++instance ToMarkup Paste where+  toMarkup paste@Paste{..} = toMarkup $ pack $ show paste++instance FromRow Paste where+  fromRow = do+    (pid,title,content,author,date,views,language,channel,annotation_of,revision_of) <- fromRow+    return $ Paste+      { pasteTitle = title+      , pasteAuthor = author+      , pasteLanguage = language+      , pasteChannel = channel+      , pastePaste = content+      , pasteDate = zonedTimeToUTC date+      , pasteId = pid+      , pasteViews = views+      , pasteType = case annotation_of of+	Just pid' -> AnnotationOf pid'+	_ -> case revision_of of+	  Just pid' -> RevisionOf pid'+	  _ -> NormalPaste+      }++-- | The type of a paste.+data PasteType+  = NormalPaste+  | AnnotationOf PasteId+  | RevisionOf PasteId+  deriving (Eq,Show)++-- | A paste submission or annotate.+data PasteSubmit = PasteSubmit {+   pasteSubmitId       :: Maybe PasteId+  ,pasteSubmitType     :: PasteType+  ,pasteSubmitTitle    :: Text+  ,pasteSubmitAuthor   :: Text+  ,pasteSubmitLanguage :: Maybe LanguageId+  ,pasteSubmitChannel  :: Maybe ChannelId+  ,pasteSubmitPaste    :: Text+  ,pasteSubmitSpamTrap :: Maybe Text+} deriving Show++data PasteFormlet = PasteFormlet {+   pfSubmitted :: Bool+ , pfErrors    :: [Text]+ , pfParams    :: Params+ , pfLanguages :: [Language]+ , pfChannels  :: [Channel]+ , pfDefChan   :: Maybe Text+ , pfAnnotatePaste :: Maybe Paste+ , pfEditPaste :: Maybe Paste+ , pfContent :: Maybe Text+}++data ExprFormlet = ExprFormlet {+   efSubmitted :: Bool+ , efParams    :: Params+}++data PastePage = PastePage {+    ppPaste           :: Paste+  , ppChans           :: [Channel]+  , ppLangs           :: [Language]+  , ppHints           :: [Hint]+  , ppAnnotations     :: [Paste]+  , ppRevisions       :: [Paste]+  , ppAnnotationHints :: [[Hint]]+  , ppRevisionsHints  :: [[Hint]]+  , ppRevision        :: Bool+}++data StepsPage = StepsPage {+    spPaste           :: Paste+  , spChans           :: [Channel]+  , spLangs           :: [Language]+  , spHints           :: [Hint]+  , spSteps           :: [Text]+  , spAnnotations     :: [Paste]+  , spAnnotationHints :: [[Hint]]+  , spForm :: Markup+}++instance ToField Severity where+  toField = toField . show++--  render = Escape . toByteString . Utf8.fromString . show+--  {-# INLINE render #-}++instance FromField Severity where+  fromField x y = fmap read (fromField x y)+  {-# INLINE fromField #-}++-- | A hlint (or like) suggestion.+data Hint = Hint {+   hintType    :: Severity+ , hintContent :: String+}++instance FromRow Hint where+  fromRow = Hint <$> field <*> field++-- instance QueryResults Hint where+--   convertResults field values = Hint {+--       hintType = severity+--     , hintContent = content+--     }+--     where (severity,content) = convertResults field values++data ReportFormlet = ReportFormlet {+   rfSubmitted :: Bool+ , rfParams    :: Params+}++data ReportSubmit = ReportSubmit {+   rsPaste :: PasteId+  ,rsComments :: String+}
+ src/Hpaste/Types/Report.hs view
@@ -0,0 +1,20 @@+module Hpaste.Types.Report where++import Hpaste.Types.Newtypes                   (PasteId)++import Control.Applicative+import Data.Text                               (Text)+import Data.Time                               (UTCTime,zonedTimeToUTC)+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow++data Report = Report {+  reportDate :: UTCTime+ ,reportPasteId :: PasteId+ ,reportComments :: Text+} deriving Show++instance FromRow Report where+  fromRow = Report <$> fmap zonedTimeToUTC field+  	    	   <*> field+		   <*> field
+ src/Hpaste/Types/Stepeval.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS -Wall -fno-warn-orphans #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The stepeval types.++module Hpaste.Types.Stepeval+       (StepevalPage(..))+       where++import Data.Text              (Text)+import Language.Haskell.HLint++data StepevalPage = StepevalPage {+    sePaste :: Text+  , seHints :: [Suggestion]+}
+ src/Hpaste/View/Activity.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Activity page view.++module Hpaste.View.Activity+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Control.Monad+import Data.Text          (Text)+import Prelude            hiding ((++))+import Text.Blaze.Html5   as H hiding (map)++-- | Render the activity page.+page :: String -> [Commit] -> Html+page repo commits =+  layoutPage $ Page {+    pageTitle = "Development activity"+  , pageBody = activity repo commits+  , pageName = "activity"+  }++-- | View the paginated pastes.+activity :: String -> [Commit] -> Html+activity repo commits = do+  darkSection "Development activity" $ do+    p $ do "Repository: "+           href repo repo+  forM_ commits $ \Commit{..} -> do+    lightSection commitTitle $ do+      p $ toHtml $ show commitDate+      p $ href commitLink ("Go to diff" :: Text)
+ src/Hpaste/View/Annotate.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Annotate paste view.++module Hpaste.View.Annotate+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Data.Monoid.Operator ((++))+import Prelude              hiding ((++))+import Text.Blaze.Html5     as H hiding (map)+import Data.Text.Lazy++-- | Render the create annotate paste page.+page :: Paste -> Html -> Html+page Paste{..} form =+  layoutPage $ Page {+    pageTitle = "Annotate: " ++ pasteTitle+  , pageBody = lightSection ("Annotate: " ++ fromStrict pasteTitle) form+  , pageName = "annotate"+  }
+ src/Hpaste/View/Browse.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Browse page view.++module Hpaste.View.Browse+  (page)+  where++import           Hpaste.Types+import           Hpaste.View.Html+import           Hpaste.View.Layout+import           Hpaste.View.Paste  (pasteLink)++import Data.Pagination+import           Control.Monad+import           Data.Maybe+import           Data.Monoid.Operator+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import           Data.Time.Show     (showDateTime)+import           Network.URI+import           Network.URI.Params+import           Prelude            hiding ((++))+import           Snap.App.Types+import           Text.Blaze.Extra+import           Text.Blaze.Pagination+import           Text.Blaze.Html5   as H hiding (map)++-- | Render the browse page.+page :: PN -> [Channel] -> [Language] -> [Paste] -> Maybe String -> Html+page pn chans langs ps mauthor =+  layoutPage $ Page {+    pageTitle = "Browse pastes"+  , pageBody = browse pn chans langs ps mauthor+  , pageName = "browse"+  }++-- | View the paginated pastes.+browse :: PN -> [Channel] -> [Language] -> [Paste] -> Maybe String -> Html+browse pn channels languages ps mauthor = do+  darkSection title $ do+    pagination pn+    table ! aClass "latest-pastes" $ do+      tr $ mapM_ (th . (toHtml :: String -> Html)) $+	 ["Title"] ++ ["Author"|isNothing mauthor] ++ ["When","Language","Channel"]+      pastes ps+    pagination pn { pnPn = (pnPn pn) { pnShowDesc = False } }++    where pastes = mapM_ $ \paste@Paste{..} -> tr $ do+                     td $ pasteLink paste pasteTitle+                     unless (isJust mauthor) $+                       td $ do+			 let author = T.unpack pasteAuthor+			 if True -- validNick author+			    then a ! hrefURI (authorUri author) $ toHtml pasteAuthor+			    else toHtml pasteAuthor+                     td $ toHtml $ showDateTime $ pasteDate+                     td $ showLanguage languages pasteLanguage+                     td $ showChannel Nothing channels pasteChannel+          authorUri author = updateUrlParam "author" author+	  	    	   $ updateUrlParam "page"   "0"+			   $ pnURI pn+          title = LT.pack $ case mauthor of+	    Just author -> "Pastes by " ++ author+	    Nothing -> "Latest pastes"
+ src/Hpaste/View/Diff.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Diff page view.++module Hpaste.View.Diff+  (page)+  where++import           Hpaste.Types+import           Hpaste.View.Html+import           Hpaste.View.Layout+import           Hpaste.View.Paste    (pasteLink)++import           Control.Monad+import           Data.Algorithm.Diff+import           Data.Monoid.Operator ((++))+import qualified Data.Text            as T+import           Data.Text.Lazy       (pack)+import           Prelude              hiding ((++))+import           Text.Blaze.Html5     as H hiding (map)++-- | Render the diff page.+page :: Paste -> Paste -> Html+page this that =+  layoutPage $ Page {+    pageTitle = "Diff two pastes"+  , pageBody = diffBody this that+  , pageName = "diff"+  }++-- | View the diff between the two pastes.+diffBody :: Paste -> Paste -> Html+diffBody this that = do+  darkSection ("Diff: " ++ pid1 ++ " / " ++ pid2) $ do+    pasteMention this pid1+    pasteMention that pid2+  lightNoTitleSection $ do+    viewDiff this that+  +    where pasteMention paste pid = p $ do+            pasteLink paste pid+            ": "+            toHtml $ pasteTitle paste+          pid1 = pack (show (pasteId this))+          pid2 = pack (show (pasteId that))++-- | View the diff between the two pastes.+viewDiff :: Paste -> Paste -> Html+viewDiff this that = do+  H.table ! aClass "code" $+    td $+      pre $ do+        forM_ groups $ \(indicator,lines) -> do+          let (ind,prefix) =+                case indicator of+                  B -> ("diff-both","  ")+                  F -> ("diff-first","- ")+                  S -> ("diff-second","+ ")+              lins = map (prefix++) lines+          H.div ! aClass ind $ toHtml $ T.unlines $ lins++    where groups = getGroupedDiff lines1 lines2+          lines1 = T.lines (pastePaste this)+          lines2 = T.lines (pastePaste that)
+ src/Hpaste/View/Edit.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Edit paste view.++module Hpaste.View.Edit+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Data.Monoid.Operator ((++))+import Prelude              hiding ((++))+import Text.Blaze.Html5     as H hiding (map)+import Data.Text.Lazy++-- | Render the create edit paste page.+page :: Paste -> Html -> Html+page Paste{..} form =+  layoutPage $ Page {+    pageTitle = "Edit: " ++ pasteTitle+  , pageBody = lightSection ("Edit: " ++ fromStrict pasteTitle) form+  , pageName = "edit"+  }
+ src/Hpaste/View/Highlight.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Code highlighting.++module Hpaste.View.Highlight+ (highlightPaste+ ,highlightHaskell)+  where++import           Hpaste.Types+import           Hpaste.View.Html++import           Control.Monad+import           Data.List                     (find)+import           Data.Monoid.Operator+import           Data.Text                     (Text,unpack,pack)+import qualified Data.Text                     as T+import           Language.Haskell.HsColour.CSS (hscolour)+import           Prelude                       hiding ((++))+import           Text.Blaze.Html5              as H hiding (map)+import qualified Text.Blaze.Html5.Attributes   as A++-- | Syntax highlight the paste.+highlightPaste :: [Language] -> Paste -> Html+highlightPaste langs Paste{..} =+  H.table ! aClass "code" $ do+    td ! aClass "line-nums" $ do+      pre $+        forM_ [1..length (T.lines pastePaste)] $ \i -> do+          let name = "line" ++ pack (show i)+          href ("#" ++ name) (toHtml i) ! A.id (toValue name) ! A.name (toValue name)+          "\n"+    td $+      case lang of+        Just (Language{languageName}) +         | elem languageName ["haskell","agda","idris"] ->+          preEscapedString $ hscolour False (unpack pastePaste)+        Just (Language{..}) ->+          pre $ code ! A.class_ (toValue $ "language-" ++ languageName) $+            toHtml pastePaste+        _ ->+          pre $ toHtml pastePaste++  where lang = find ((==pasteLanguage) . Just . languageId) langs++highlightHaskell :: Text -> Html+highlightHaskell paste =+  H.table ! aClass "code" $+    td $ preEscapedString $ hscolour False (unpack paste)
+ src/Hpaste/View/Hlint.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Show hlint suggestions.++module Hpaste.View.Hlint+ (viewHints+ ,viewSuggestions)+  where++import Hpaste.Types+import Hpaste.View.Html++import Data.List              (intersperse)+import Language.Haskell.HLint+import Prelude                hiding ((++))+import Text.Blaze.Html5       as H hiding (map)++-- | Show hlint hints for a Haskell paste.+viewHints :: [Hint] -> Html+viewHints = mapM_ showHint where+  showHint hint =+    section $+      pre ! aClass "hint" $ sequence_ $ intersperse br $ map toHtml lns+    where section = case hintType hint of+                      Ignore  -> \_ -> return ()+                      Warning -> warnNoTitleSection+                      Error   -> errorNoTitleSection+          lns = lines $ clean $ hintContent hint+          clean = dropWhile (==':') . dropWhile (/=':')++viewSuggestions :: [Suggestion] -> Html+viewSuggestions = viewHints . map toHint where+  toHint s = Hint (suggestionSeverity s)+                  (show s)
+ src/Hpaste/View/Home.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Home page view.++module Hpaste.View.Home+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout+import Hpaste.View.Paste  (pasteLink)++import Control.Monad+import Data.Text          (Text)+import Data.Time.Show     (showDateTime)+import Prelude            hiding ((++))+import Text.Blaze.Html5   as H hiding (map)+import qualified Data.Text as T+import Text.Blaze.Extra+import Network.URI.Params+import Network.URI++-- | Render the home page.+page :: URI -> [Channel] -> [Language] -> [Paste] -> Html -> Bool -> Html+page uri chans langs ps form spam =+  layoutPage $ Page {+    pageTitle = "Recent pastes"+  , pageBody = content uri chans langs ps form spam+  , pageName = "home"+  }++-- | Render the home page body.+content :: URI -> [Channel] -> [Language] -> [Paste] -> Html -> Bool -> Html+content uri chans langs ps form spam = do+  when spam $ p $ strong $ do "Your submission was identified as being probably spam and was ignored. "+                              "Try reducing links and making your paste look less spammy. "+			      "If the problem persists, try contacting support and we will adjust the spam filters."+  createNew form+  latest uri chans langs ps++-- | Create a new paste section.+createNew :: Html -> Html+createNew = lightSection "Create new paste"++-- | View the latest pastes.+latest :: URI -> [Channel] -> [Language] -> [Paste] -> Html+latest uri channels languages ps = do+  darkSection "Latest pastes" $ do+    table ! aClass "latest-pastes" $ do+      tr $ mapM_ (th . toHtml) $ words "Title Author When Language Channel"+      pastes ps+    p ! aClass "browse-link" $ browse++    where pastes = mapM_ $ \paste@Paste{..} -> tr $ do+                     td $ pasteLink paste pasteTitle+                     td $ do+                       let author = T.unpack pasteAuthor+		       if True -- validNick author+		       	  then a ! hrefURI (authorUri author) $ toHtml pasteAuthor+			  else toHtml pasteAuthor+                     td $ toHtml $ showDateTime $ pasteDate+                     td $ showLanguage languages pasteLanguage+                     td $ showChannel Nothing channels pasteChannel+          authorUri author = updateUrlParam "author" author+	  	    	   $ updateUrlParam "page"   "0"+			   $ uri { uriPath = "/browse" }++-- | Browse link.+browse :: Html+browse = href ("/browse" :: Text) ("Browse all pastes" :: Text)
+ src/Hpaste/View/Html.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | HTML-specific view functions.++module Hpaste.View.Html+  (aClass+  ,aClasses+  ,darkSection+  ,darkNoTitleSection+  ,lightSection+  ,lightNoTitleSection+  ,warnNoTitleSection+  ,errorNoTitleSection+  ,href+  ,clear+  ,showLanguage+  ,showChannel+  ,paginate+  ,preEscapedString)+  where++import           Hpaste.Types++import           Control.Arrow               ((&&&))+import           Control.Monad               (when)+import           Data.Maybe                  (fromMaybe)+import           Data.Monoid.Operator        ((++))+import           Data.Pagination+import           Data.Text.Lazy              (Text)+import qualified Data.Text.Lazy              as T+import           Network.URI.Params+import           Network.URI+import           Prelude                     hiding ((++))+import           Text.Blaze.Html5            as H hiding (map,nav)+import qualified Text.Blaze.Html5.Attributes as A+import           Text.Blaze.Extra+import Snap.App.Types++-- | A class prefixed with amelie-.+aClass :: AttributeValue -> Attribute+aClass name = A.class_ ("amelie-" ++ name)++-- | A class prefixed with amelie-.+aClasses :: [Text] -> Attribute+aClasses names = A.class_ $+  toValue $ T.intercalate " " $ map ("amelie-" ++) names++-- | A warning section.+warnNoTitleSection :: Markup -> Markup+warnNoTitleSection inner =+  H.div ! aClasses ["section","section-warn"] $ do+    inner++-- | An error section.+errorNoTitleSection :: Markup -> Markup+errorNoTitleSection inner =+  H.div ! aClasses ["section","section-error"] $ do+    inner++-- | A dark section.+darkSection :: Text -> Markup -> Markup+darkSection title inner =+  H.div ! aClasses ["section","section-dark"] $ do+    h2 $ toMarkup title+    inner++-- | A dark section.+darkNoTitleSection :: Markup -> Markup+darkNoTitleSection inner =+  H.div ! aClasses ["section","section-dark"] $ do+    inner++-- | A light section.+lightSection :: Text -> Markup -> Markup+lightSection title inner =+  H.div ! aClasses ["section","section-light"] $ do+    h2 $ toMarkup title+    inner++-- | A light section with no title.+lightNoTitleSection :: Markup -> Markup+lightNoTitleSection inner =+  H.div ! aClasses ["section","section-light"] $ do+    inner++-- | An anchor link.+href :: (ToValue location,ToMarkup html) => location -> html -> Markup+href loc content = H.a ! A.href (toValue loc) $ toMarkup content++-- | A clear:both element.+clear :: Markup+clear = H.div ! aClass "clear" $ return ()++-- | Show a language.+showLanguage :: [Language] -> Maybe LanguageId -> Markup+showLanguage languages lid =+  toMarkup $ fromMaybe "-" (lid >>= (`lookup` langs))++    where langs = map (languageId &&& languageTitle) languages++-- | Show a channel.+showChannel :: Maybe Paste -> [Channel] -> Maybe ChannelId -> Markup+showChannel paste channels lid = do+  toMarkup $ fromMaybe "-" chan+  case (paste,chan) of+    (Just paste,Just c) | c == "#haskell" -> do+      " "+      href ("http://ircbrowse.net/browse/haskell/?q=hpaste+" ++ show (pasteId paste)) $+        ("Context in IRC logs" :: String)+    _ -> return ()++    where langs = map (channelId &&& channelName) channels+          chan = (lid >>= (`lookup` langs))++-- | Render results with pagination.+paginate :: URI -> Pagination -> Markup -> Markup+paginate uri pn inner = do+  nav uri pn True+  inner+  nav uri pn False++-- | Show a pagination navigation, with results count, if requested.+nav :: URI -> Pagination -> Bool -> Markup+nav uri pn@Pagination{..} showTotal = do+  H.div ! aClass "pagination" $ do+    H.div ! aClass "inner" $ do+      when (pnCurrentPage-1 > 0) $ navDirection uri pn (-1) "Previous"+      toMarkup (" " :: Text)+      when (pnTotal == pnPerPage) $ navDirection uri pn 1 "Next"+      when showTotal $ do+        br+        toMarkup $ results++    where results = unwords [show start ++ "—" ++ show end+                            ,"results of"+                            ,show pnTotal]+          start = 1 + (pnCurrentPage - 1) * pnTotal+          end = pnCurrentPage * pnTotal++-- | Link to change navigation page based on a direction.+navDirection :: URI -> Pagination -> Integer -> Text -> Markup+navDirection uri Pagination{..} change caption = do+  a ! hrefURI uri $ toMarkup caption++  where uri = updateUrlParam "page"+  	      		     (show (pnCurrentPage + change))+			     uri++-- | Migration function.+preEscapedString :: String -> Markup+preEscapedString = preEscapedToMarkup
+ src/Hpaste/View/Irclogs.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Irclogs page view.++module Hpaste.View.Irclogs+  (page)+  where++import           Hpaste.Types+import           Hpaste.View.Html+import           Hpaste.View.Layout++import           Control.Monad+import           Data.Char+import           Data.Maybe+import           Data.Monoid.Operator ((++))+import           Data.String+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Prelude              hiding ((++))+import           Text.Blaze.Extra+import           Text.Blaze.Html5     as H hiding (map)+import qualified Text.Blaze.Html5.Attributes   as A++-- | Render the irclogs page.+page :: String -> String -> String -> Either String [Text] -> Maybe Integer -> Html+page channel date time entries pid =+  layoutPage $ Page {+    pageTitle = "Development irclogs"+  , pageBody = irclogs pid channel entries+  , pageName = "irclogs"+  }++-- | View the paginated pastes.+irclogs :: Maybe Integer -> String -> Either String [Text] -> Html+irclogs pid channel entries = do+  darkSection "IRC logs" $ do+    p $ do "Channel: #"; toHtml channel+  lightSection (fromString ("#" ++ channel)) $ do+    case entries of+      Left error    -> do "Unable to get logs for this channel and date: "+                          toHtml error+      Right entries -> +        ul !. "amelie-irc-entries" $+          forM_ entries $ \entry -> do+            let date = toValue $ parseDate entry+                url = "http://hpaste.org/" ++ maybe "0" (T.pack . show) pid+                currentline | T.isSuffixOf url entry = "current"+                            | otherwise = ""+            li !. (toValue (currentline :: Text)) $ do+              a ! A.name date ! A.id date $ return ()+              toHtml entry++  where parseDate = T.replace ":" "-" . T.takeWhile (not.isSpace)
+ src/Hpaste/View/Layout.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Page layout.++module Hpaste.View.Layout+  (layoutPage)+  where++import           Hpaste.Types+import           Hpaste.View.Html++import           Data.Monoid.Operator        ((++))+import           Prelude                     hiding ((++))+import           Text.Blaze.Html5            as H hiding (map,nav)+import qualified Text.Blaze.Html5.Attributes as A++-- | Render the page in a layout.+layoutPage :: Page -> Markup+layoutPage Page{..} = do+  docTypeHtml $ do+    H.head $ do+      meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8"+      link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/css/amelie.css"+      js "jquery.js"+      js "amelie.js"+      js "fudge.js"+      js "highlight.pack.js"+      title $ toMarkup $ pageTitle ++ " :: hpaste — Haskell Pastebin"+      script $+        "hljs.tabReplace = '    ';hljs.initHighlightingOnLoad();"+    body ! A.id (toValue pageName) $ do+      wrap $ do+        nav+        logo+        pageBody+        foot+      preEscapedString "<script type=\"text/javascript\"> var _gaq = _gaq \+                       \|| []; _gaq.push(['_setAccount', 'UA-7443395-10']);\+                       \ _gaq.push(['_trackPageview']); (function() {var ga\+                       \ = document.createElement('script'); ga.type = 'tex\+                       \t/javascript'; ga.async = true; ga.src = ('https:' \+                       \== document.location.protocol ? 'https://ssl' : \+                       \'http://www') + '.google-analytics.com/ga.js'; var\+                       \ s = document.getElementsByTagName('script')[0]; \+                       \s.parentNode.insertBefore(ga, s);})(); </script>"++    where js s = script ! A.type_ "text/javascript"+                        ! A.src ("/js/" ++ s) $+                        return ()++-- | Show the hpaste logo.+logo :: Markup+logo = do+  a ! aClass "logo" ! A.href "/" ! A.title "Back to home" $ do+    "hpaste"++-- | Layout wrapper.+wrap :: Markup -> Markup+wrap x = H.div ! aClass "wrap" $ x++-- | Navigation.+nav :: Markup+nav = do+  H.div ! aClass "nav" $ do+    a ! A.href "mailto:chrisdone@gmail.com" $ "Contact/support"+    " | "+    a ! A.href "/activity" $ "Changelog"++-- | Page footer.+foot :: Markup+foot = H.div ! aClass "footer" $ p $+  lnk "http://github.com/chrisdone/hpaste" "Web site source code on Github"+  //+  lnk "http://book.realworldhaskell.org/" "Real World Haskell"+  //+  lnk "http://haskell.org/" "Haskell.org"+  //+  lnk "http://planet.haskell.org/" "Planet Haskell"++    where lnk url t = href (url :: String) (t :: String)+          left // right = do _ <- left; (" / " :: Markup); right
+ src/Hpaste/View/New.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Create new paste view.++module Hpaste.View.New+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Prelude            hiding ((++))+import Text.Blaze.Html5   as H hiding (map)++-- | Render the create new paste page.+page :: Html -> Html+page form =+  layoutPage $ Page {+    pageTitle = "Create new paste"+  , pageBody = lightSection "Create new paste" form+  , pageName = "new"+  }
+ src/Hpaste/View/Paste.hs view
@@ -0,0 +1,273 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Paste views.++module Hpaste.View.Paste+  (pasteFormlet+  ,page+  ,pasteLink+  ,pasteRawLink)+  where+++import           Hpaste.Types+import           Hpaste.View.Highlight       (highlightPaste)+import           Hpaste.View.Hlint           (viewHints)+import           Hpaste.View.Html+import           Hpaste.View.Layout++import           Control.Applicative+import           Control.Arrow               ((&&&))+import           Control.Monad+import           Data.ByteString.UTF8        (toString)+import           Data.List                   (find,nub)+import qualified Data.Map                    as M+import           Data.Maybe+import           Data.Monoid.Operator        ((++))+import           Data.Text                   (Text,pack)+import qualified Data.Text                   as T+import           Data.Text.Lazy              (fromStrict)+import           Data.Time.Show              (showDateTime)+import           Data.Traversable hiding (forM)++import           Prelude                     hiding ((++))+import           Safe                        (readMay)+import           Text.Blaze.Html5            as H hiding (map)+import qualified Text.Blaze.Html5.Attributes as A+import           Text.Blaze.Html5.Extra+import           Text.Blaze.Extra+import           Text.Formlet++-- | Render the page page.+page :: PastePage -> Markup+page PastePage{ppPaste=p@Paste{..},..} =+  layoutPage $ Page {+    pageTitle = pasteTitle+  , pageBody = do viewPaste (if ppRevision then [] else ppRevisions)+    	       	  	    []+			    ppChans+			    ppLangs+			    (p,case ppRevisionsHints of (hints:_) -> hints; _ -> ppHints)+                  viewAnnotations (p : ppAnnotations)+                                  ppChans+                                  ppLangs+                                  (zip ppAnnotations ppAnnotationHints)+  , pageName = "paste"+  }++-- | A formlet for paste submission / annotateing.+pasteFormlet :: PasteFormlet -> (Formlet PasteSubmit,Markup)+pasteFormlet pf@PasteFormlet{..} =+  let form = postForm ! A.action (toValue action) $ do+        when pfSubmitted $+          when (not (null pfErrors)) $+            H.div ! aClass "errors" $+              mapM_ (p . toMarkup) pfErrors+        formletHtml (pasteSubmit pf) pfParams+        p $ do submitI "public" "Create Public Paste"+               " "+               submitI "private" "Create Secret Paste"+  in (pasteSubmit pf,form)++  where action = case pfAnnotatePaste of+                   Just Paste{..} -> "/annotate/" ++ show (fromMaybe pasteId pasteParent)+                       where pasteParent = case pasteType of+                               AnnotationOf pid -> Just pid+                               _ -> Nothing+                   Nothing        ->+                     case pfEditPaste of+		       Just Paste{..} -> "/edit/" ++ show pasteId+		       Nothing -> "/new"+++-- | Make a submit (captioned) button.+submitI :: Text -> Text -> Markup+submitI name caption =+  H.input ! A.type_ "submit"+          ! A.name (toValue name)+          ! A.value (toValue caption)+++-- | The paste submitting formlet itself.+pasteSubmit :: PasteFormlet -> Formlet PasteSubmit+pasteSubmit pf@PasteFormlet{..} =+  PasteSubmit+    <$> pure (getPasteId pf)+    <*> pure (case pfAnnotatePaste of+    	       Just pid -> AnnotationOf (pasteId pid)+	       _ -> case pfEditPaste of+	         Just pid -> RevisionOf (pasteId pid)+		 _ -> NormalPaste)+    <*> req (textInput "title" "Title" (annotateTitle <|> editTitle))+    <*> defaulting "Anonymous Coward" (textInput "author" "Author" Nothing)+    <*> parse (traverse lookupLang)+              (opt (dropInput languages "language" "Language" (snd defChan)))+    <*> parse (traverse lookupChan)+              (opt (dropInput channels "channel" "Channel" (fst defChan)))+    <*> req (areaInput "paste" "Paste" pfContent)+    <*> opt (wrap (H.div ! aClass "spam") (textInput "email" "Email" Nothing))++    where defaulting def = fmap swap where+    	    swap "" = def+	    swap x  = x+    	  channels = options channelName channelName pfChannels+          languages = options languageName languageTitle pfLanguages++          lookupLang slug = findOption ((==slug).languageName) pfLanguages languageId+          lookupChan slug = findOption ((==slug).channelName) pfChannels channelId++          defChan = maybe (fromMaybe "" (annotateChan <|> editChan)+	  	    	  ,fromMaybe "haskell" (annotateLanguage <|> editLanguage))+                          (channelName &&& trim.channelName)+                          (pfDefChan >>= findChan)+          findChan name = find ((==name).trim.channelName) pfChannels+          trim = T.dropWhile (=='#')++          annotateTitle = ((++ " (annotation)") . pasteTitle) <$> pfAnnotatePaste+          annotateLanguage = join (fmap pasteLanguage pfAnnotatePaste) >>= findLangById+          annotateChan = join (fmap pasteChannel pfAnnotatePaste) >>= findChanById++          editTitle = Nothing+          editLanguage = join (fmap pasteLanguage pfEditPaste) >>= findLangById+          editChan = join (fmap pasteChannel pfEditPaste) >>= findChanById++          findChanById id = channelName <$> find ((==id).channelId) pfChannels+          findLangById id = languageName <$> find ((==id).languageId) pfLanguages++-- | Get the paste id.+getPasteId :: PasteFormlet -> Maybe PasteId+getPasteId PasteFormlet{..} =+  M.lookup "id" pfParams >>=+  readMay . concat . map toString >>=+  return . PasteId++-- | View the paste's annotations.+viewAnnotations :: [Paste] -> [Channel] -> [Language] -> [(Paste,[Hint])] -> Markup+viewAnnotations pastes chans langs annotations = do+  mapM_ (viewPaste [] pastes chans langs) annotations++-- | View a paste's details and content.+viewPaste :: [Paste] -> [Paste] -> [Channel] -> [Language] -> (Paste,[Hint]) -> Markup+viewPaste revisions annotations chans langs (paste@Paste{..},hints) = do+  pasteDetails revisions annotations chans langs paste+  pasteContent revisions langs paste+  viewHints hints++-- | List the details of the page in a dark section.+pasteDetails :: [Paste] -> [Paste] -> [Channel] -> [Language] -> Paste -> Markup+pasteDetails revisions annotations chans langs paste =+  darkNoTitleSection $ do+    pasteNav annotations paste+    h2 $ toMarkup $ fromStrict (pasteTitle paste)+    ul ! aClass "paste-specs" $ do+      detail "Paste" $ do+        pasteLink paste $ "#" ++ show (pasteId paste)+	" "+        linkToParent paste+      detail "Author(s)" $ do+        let authors | null revisions = map pasteAuthor [paste]+	    	    | otherwise      = map pasteAuthor revisions+        htmlCommasAnd $ flip map (nub authors) $ \author ->+	  linkAuthor author+      detail "Language" $ showLanguage langs (pasteLanguage paste)+      detail "Channel" $ showChannel (Just paste) chans (pasteChannel paste)+      detail "Created" $ showDateTime (pasteDate paste)+      detail "Raw" $ pasteRawLink paste $ ("View raw link" :: Text)+      unless (length revisions < 2) $ detail "Revisions" $ do+        br+        ul !. "revisions" $ listRevisions paste revisions+    clear++    where detail title content = do+            li $ do strong (title ++ ":"); toMarkup content++-- | Link to an author.+linkAuthor :: Text -> Markup+linkAuthor author = href ("/browse?author=" ++ author) $ toMarkup author++-- | Link to annotation/revision parents.+linkToParent :: Paste -> Markup+linkToParent paste = do+  case pasteType paste of+    NormalPaste -> return ()+    AnnotationOf pid -> do "(an annotation of "; pidLink pid; ")"+    RevisionOf pid -> do "(a revision of "; pidLink pid; ")"++-- | List the revisions of a paste.+listRevisions :: Paste -> [Paste] -> Markup+listRevisions _ [] = return ()+listRevisions p [x] = revisionDetails p x+listRevisions p (x:y:xs) = do+  revisionDetails y x+  listRevisions p (y:xs)++-- | List the details of a revision.+revisionDetails :: Paste -> Paste -> Markup+revisionDetails paste revision = li $ do+  toMarkup $ showDateTime (pasteDate revision)+  " "+  revisionLink revision $ do "#"; toMarkup (show (pasteId revision))+  unless (pasteId paste == pasteId revision) $ do+    " "+    href ("/diff/" ++ show (pasteId paste) ++ "/" ++ show (pasteId revision)) $+      ("(diff)" :: Markup)+  ": "+  toMarkup (pasteTitle revision)+  " ("+  linkAuthor (pasteAuthor revision)+  ")"++-- | Individual paste navigation.+pasteNav :: [Paste] -> Paste -> Markup+pasteNav pastes paste =+  H.div ! aClass "paste-nav" $ do+    diffLink+    href ("/edit/" ++ pack (show pid) ++ "") ("Edit" :: Text)+    " - "+    href ("/annotate/" ++ pack (show pid) ++ "") ("Annotate" :: Text)+    " - "+    href ("/report/" ++ pack (show pid) ++ "") ("Report/Delete" :: Text)++    where pid = pasteId paste+          pairs = zip (drop 1 pastes) pastes+          parent = fmap snd $ find ((==pid).pasteId.fst) $ pairs+          diffLink = do+            case listToMaybe pastes of+              Nothing -> return ()+              Just Paste{pasteId=parentId} -> do+                href ("/diff/" ++ show parentId ++ "/" ++ show pid)+                     ("Diff original" :: Text)+            case parent of+              Nothing -> return ()+              Just Paste{pasteId=prevId} -> do+	        when (pasteType paste /= AnnotationOf prevId) $ do+                  " / "+                  href ("/diff/" ++ show prevId ++ "/" ++ show pid)+                       ("prev" :: Text)+            case listToMaybe pastes of+              Nothing -> return (); Just{} -> " - "++-- | Show the paste content with highlighting.+pasteContent :: [Paste] -> [Language] -> Paste -> Markup+pasteContent revisions langs paste =+  case revisions of+    (rev:_) -> lightNoTitleSection $ highlightPaste langs rev+    _ -> lightNoTitleSection $ highlightPaste langs paste++-- | The href link to a paste.+pasteLink :: ToMarkup html => Paste -> html -> Markup+pasteLink Paste{..} inner = href ("/" ++ show pasteId) inner++-- | The href link to a paste pid.+pidLink :: PasteId -> Markup+pidLink pid = href ("/" ++ show pid) $ toMarkup $ "#" ++ show pid++-- | The href link to a paste.+revisionLink :: ToMarkup html => Paste -> html -> Markup+revisionLink Paste{..} inner = href ("/revision/" ++ show pasteId) inner++-- | The href link to a paste, raw content.+pasteRawLink :: ToMarkup html => Paste -> html -> Markup+pasteRawLink Paste{..} inner = href ("/raw/" ++ show pasteId) inner
+ src/Hpaste/View/Report.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Report view.++module Hpaste.View.Report+  (page,reportFormlet)+  where++import           Hpaste.Types+import           Hpaste.View.Highlight+import           Hpaste.View.Html+import           Hpaste.View.Layout++import           Data.Monoid.Operator        ((++))+import           Data.Text                   (Text)+import           Prelude                     hiding ((++))+import           Text.Blaze.Html5            as H hiding (map)+import qualified Text.Blaze.Html5.Attributes as A+import           Text.Formlet++-- | Render the page page.+page :: Html -> Paste -> Html+page form paste =+  layoutPage $ Page {+    pageTitle = "Report a paste"+  , pageBody = do reporting form; viewPaste paste+  , pageName = "paste"+  }+  +reporting :: Html -> Html+reporting form = do+  lightSection "Report a paste" $ do+    p $ do "Please state any comments regarding the paste:"+    H.form ! A.method "post" $ do+      form++-- | View a paste's details and content.+viewPaste :: Paste -> Html+viewPaste Paste{..} = do+  pasteDetails pasteTitle+  pasteContent pastePaste++-- | List the details of the page in a dark section.+pasteDetails :: Text -> Html+pasteDetails title =+  darkNoTitleSection $ do+    pasteNav+    h2 $ toHtml title+    ul ! aClass "paste-specs" $ do+      detail "Language" $ "Haskell"+      detail "Raw" $ href ("/stepeval/raw" :: Text)+                          ("View raw link" :: Text)+    clear++    where detail title content = do+            li $ do strong (title ++ ":"); content++-- | Individual paste navigation.+pasteNav :: Html+pasteNav =+  H.div ! aClass "paste-nav" $ do+    href ("https://github.com/benmachine/stepeval" :: Text)+         ("Go to stepeval project" :: Text)++-- | Show the paste content with highlighting.+pasteContent :: Text -> Html+pasteContent paste =+  lightNoTitleSection $+    highlightHaskell paste++-- | A formlet for report submission / annotating.+reportFormlet :: ReportFormlet -> (Formlet Text,Html)+reportFormlet ReportFormlet{..} =+  let frm = form $ do+        formletHtml reportSubmit rfParams+        submitInput "submit" "Submit"+  in (reportSubmit,frm)++reportSubmit :: Formlet Text+reportSubmit = req (textInput "report" "Comments" Nothing)
+ src/Hpaste/View/Reported.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Reported page view.++module Hpaste.View.Reported+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Text.Blaze.Pagination+import Data.Monoid.Operator ((++))+import Data.Time.Show       (showDateTime)+import Prelude              hiding ((++))+import Network.URI+import Text.Blaze.Html5     as H hiding (map)+import Snap.App.Types++-- | Render the reported page.+page :: PN -> [Report] -> String -> Html+page pn rs key =+  layoutPage $ Page {+    pageTitle = "Reported pastes"+  , pageBody = reported pn rs key+  , pageName = "reported"+  }++-- | View the paginated reports.+reported :: PN -> [Report] -> String -> Html+reported pn rs key = do+  darkSection "Reported pastes" $ do+    pagination pn+    table ! aClass "latest-pastes" $ do+      tr $ mapM_ (th . toHtml) $ words "Date Paste Delete Comments"+      reports rs+    pagination pn++    where reports = mapM_ $ \Report{..} -> tr $ do+                      td $ toHtml $ showDateTime reportDate+                      td $ href ("/" ++ show reportPasteId ++ "?show_private=true") $ show reportPasteId+		      td $ href ("/delete?id=" ++ show reportPasteId ++ "&key=" ++ key) ("Delete"::String)+                      td $ toHtml reportComments
+ src/Hpaste/View/Script.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Page script.++module Hpaste.View.Script+  (script)+  where++import Data.Text.Lazy                (Text,pack)+import HJScript+import HJScript.Objects.JQuery       hiding (prepend,append)+import HJScript.Objects.JQuery.Extra+import Prelude                       hiding ((++),max)++-- | All scripts on the site. Not much to do.+script :: Text+script = pack $ show $ snd $ evalHJScript $ do+  ready $ do+--    resizePage+    toggleHints+    togglePaste++-- | Resize the width of the page to match content width.+resizePage :: HJScript ()+resizePage = do+  max <- varWith (int 0)+  each (do max .=. (mathMax 500+                            (mathMax (getWidth this' + 50) (val max)))+           return true)+       (j ".amelie-code")+  each (do setWidth (mathMax (val max) 500)+                    (j ".amelie-wrap")+           return true)+       (j ".amelie-code")+  each (do setWidth (mathMax (getWidth this') 500)+                    (j ".amelie-wrap")+           return true)+       (j ".amelie-latest-pastes")+       +-- | Collapse/expand hints when toggled.+toggleHints :: HJScript ()+toggleHints = do+  each (do this <- varWith this'+           collapse this+           css' "cursor" "pointer" (parent this)+           toggle (expand this)+                  (collapse this)+                  (parent this)+           return true)+       (j ".amelie-hint")++    where collapse o = do+            css "height" "1em" o+            css "overflow" "hidden" o+            return false+          expand o = do+            css "height" "auto" o+            return false++-- | Toggle paste details.+togglePaste :: HJScript ()+togglePaste = do+  each (do btn <- varWith (j "<a href=\"\">Expand</a>")+           this <- varWith this'+           prepend (string " - ") this+           prepend (val btn) this+           details <- varWith (siblings ".amelie-paste-specs" this)+           display btn "none" details+           toggle (display btn "block" details)+                  (display btn "none" details)+                  btn+           return true)+       (j ".amelie-paste-nav")++   where display btn prop o = do+           css "display" prop o+           setText (string caption) btn+           return false+           where caption = if prop == "block" then "Collapse" else "Expand"
+ src/Hpaste/View/Stepeval.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Stepeval explanation view.++module Hpaste.View.Stepeval+  (page)+  where++import           Hpaste.Types+import           Hpaste.View.Highlight+import           Hpaste.View.Hlint+import           Hpaste.View.Html+import           Hpaste.View.Layout++import           Data.Monoid.Operator        ((++))+import           Data.Text                   (Text)+import           Language.Haskell.HLint+import           Prelude                     hiding ((++))+import           Text.Blaze.Html5            as H hiding (map)++-- | Render the page page.+page :: StepevalPage -> Html+page StepevalPage{..} =+  layoutPage $ Page {+    pageTitle = "Stepeval support"+  , pageBody = do explanation+                  viewPaste sePaste seHints+  , pageName = "paste"+  }+  +explanation :: Html+explanation = do+  lightSection "Stepeval" $ do+    p $ do "A program/library for evaluating "+           "a Haskell expression step-by-step. This web site uses it "+           "for stepping through provided expressions."+    p $ href ("https://github.com/benmachine/stepeval" :: Text)+             ("Repository for Stepeval" :: Text)+    p $ do "Stepeval comes with a simple Prelude of pure functions "+           "(see below) that can be used when stepping through "+           "expressions. This may be expanded upon in the future."+    p $ do "This web site will automatically include declarations "+           "from the paste as the expression to be evaluted."++-- | View a paste's details and content.+viewPaste :: Text -> [Suggestion] -> Html+viewPaste paste hints = do+  pasteDetails "Stepeval Prelude"+  pasteContent paste+  viewSuggestions hints++-- | List the details of the page in a dark section.+pasteDetails :: Text -> Html+pasteDetails title =+  darkNoTitleSection $ do+    pasteNav+    h2 $ toHtml title+    ul ! aClass "paste-specs" $ do+      detail "Language" $ "Haskell"+      detail "Raw" $ href ("/stepeval/raw" :: Text)+                          ("View raw link" :: Text)+    clear++    where detail title content = do+            li $ do strong (title ++ ":"); content++-- | Individual paste navigation.+pasteNav :: Html+pasteNav =+  H.div ! aClass "paste-nav" $ do+    href ("https://github.com/benmachine/stepeval" :: Text)+         ("Go to stepeval project" :: Text)++-- | Show the paste content with highlighting.+pasteContent :: Text -> Html+pasteContent paste =+  lightNoTitleSection $+    highlightHaskell paste
+ src/Hpaste/View/Steps.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Paste steps view.++module Hpaste.View.Steps+  (page+  ,exprFormlet)+  where++import           Hpaste.Types+import           Hpaste.View.Highlight+import           Hpaste.View.Hlint           (viewHints)+import           Hpaste.View.Html+import           Hpaste.View.Layout+import           Hpaste.View.Paste           (pasteLink)++import           Control.Monad+import           Data.Monoid.Operator        ((++))+import           Data.Text                   (Text)+import qualified Data.Text                   as T+import           Data.Text.Lazy              (fromStrict)+import           Prelude                     hiding ((++),div)+import           Text.Blaze.Html5            as H hiding (map)+import qualified Text.Blaze.Html5.Attributes as A+import           Text.Formlet++-- | Render the steps page.+page :: StepsPage -> Html+page StepsPage{spPaste=p@Paste{..},..} =+  layoutPage $ Page {+    pageTitle = pasteTitle+  , pageBody = viewPaste spForm p spHints spSteps+  , pageName = "steps"+  }++-- | View a paste's details and content.+viewPaste :: Html -> Paste -> [Hint] -> [Text] -> Html+viewPaste form paste@Paste{..} hints steps = do+  case pasteParent of+    Nothing -> return ()+    Just{}  -> let an = "a" ++ show (fromIntegral pasteId :: Integer)+               in a ! A.name (toValue an) $ return ()+  pasteDetails paste+  pasteContent paste+  stepsForm form+  viewSteps steps+  viewHints hints++stepsForm :: Html -> Html+stepsForm form =+  lightNoTitleSection $+    div ! aClass "steps-expr" $+      form++-- | A formlet for expr submission / annotating.+exprFormlet :: ExprFormlet -> (Formlet Text,Html)+exprFormlet ExprFormlet{..} =+  let frm = form $ do+        formletHtml exprSubmit efParams+        submitInput "submit" "Submit"+  in (exprSubmit,frm)++exprSubmit :: Formlet Text+exprSubmit = req (textInput "expr" "Expression" Nothing)++viewSteps :: [Text] -> Html+viewSteps steps =+  lightSection "Steps (displaying 50 max.)" $+    div ! aClass "steps" $ do+      highlightHaskell $ T.intercalate "\n\n" steps++-- | List the details of the page in a dark section.+pasteDetails :: Paste -> Html+pasteDetails paste@Paste{..} =+  darkNoTitleSection $ do+    pasteNav+    h2 $ toHtml $ fromStrict pasteTitle+    ul ! aClass "paste-specs" $ do+      detail "Paste" $ pasteLink paste $ "#" ++ show pasteId+      detail "Author" $ pasteAuthor+    clear++    where detail title content = do+            li $ do strong (title ++ ":"); toHtml content++-- | Individual paste navigation.+pasteNav :: Html+pasteNav =+  H.div ! aClass "paste-nav" $ do+    href ("/stepeval" :: Text)+         ("About evaluation step support" :: Text)++-- | Show the paste content with highlighting.+pasteContent :: Paste -> Html+pasteContent paste =+  lightNoTitleSection $ highlightHaskell (pastePaste paste)
+ src/Hpaste/View/Style.hs view
@@ -0,0 +1,323 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Page style.++module Hpaste.View.Style+  (style)+  where++import Data.Monoid.Operator ((++))+import Data.Text.Lazy       (Text)+import Prelude              hiding ((++))+import Language.CSS++-- | Side-wide style sheet.+style :: Text+style = renderCSS $ runCSS $ do+  layout+  sections+  paste+  utils+  highlighter+  hints+  form+  home+  browse+  footer+  activity+  ircEntries+  +-- | IRC log entries.+ircEntries :: CSS Rule+ircEntries = do+  classRule "irc-entries" $ do+    marginLeft "0"+    paddingLeft "0"+    listStyle "none"+    rule ".current" $ do+      fontWeight "bold"+      marginTop "1em"+      marginBottom "1em"++-- | Footer.+footer :: CSS Rule+footer = do+  classRule "footer" $ do+    textAlign "center"+    rule "a" $ do +      textDecoration "none"+    rule "a:hover" $ do+      textDecoration "underline"++-- | General layout styles.+layout :: CSS Rule+layout = do+  rule "body" $ do+    fontFamily "'DejaVu Sans', sans-serif"+    fontSize "13px"+    textAlign "center"+    +  classRule "logo" $ do+    margin "1em 0 1em 0"+    border "0"+    background "url(/css/hpaste.png) no-repeat"+    width "190px"+    height "50px"+    display "block"+    textIndent "-999px"+  +  classRule "wrap" $ do+    margin "auto"+    textAlign "left"+    +  classRule "nav" $ do+    float "right"+    marginTop "1em"++-- | Paste form.+form :: CSS Rule+form = do+  inputs+  classRule "spam" $ do+    display "none"+  classRule "errors" $ do+    color "#743838"+    fontWeight "bold"++-- | Input style.+inputs :: CSS Rule+inputs =+  rule "form p label" $ do+    rule "textarea" $ do+      width "100%"+      height "20em"+      clear "both"+      margin "1em 0 0 0"+         +    rule "textarea, input.text" $ do+      border "2px solid #ddd"+      borderRadius "4px"+    rule "textarea:focus, input.text:focus" $ do+      background "#eee"+      +    rule "span" $ do+      float "left"+      width "7em"+      display "block"++-- | Section styles.+sections :: CSS Rule+sections = do+  classRule "section" $ do+    borderRadius "5px"+    padding "10px"+    border "3px solid #000"+    margin "0 0 0.5em 0"+     +    rule "h2" $ do+      margin "0"+      fontSize "1.2em"+      padding "0"+  +  classRule "section-dark" $ do+    background "#453D5B"+    borderColor "#A9A0D2"+    color "#FFF"++    rule "h2" $ do+      color "#FFF"+    +    rule "a" $ do+      color "#8ae0c2"+      textDecoration "none"++    rule "a:hover" $ do+      textDecoration "underline"++  classRule "section-light" $ do+    background "#FFF"+    borderColor "#EEE"+    color "#000"++    rule "h2" $ do+      color "#2D2542"+   +  classRule "section-error" $ do+    background "#FFDFDF"+    color "#5b4444"+    border "1px solid #EFB3B3"++    rule "pre" $ do+      margin "0"+    rule "h2" $ do+      color "#2D2542"+   +  classRule "section-warn" $ do+    background "#FFF9C7"+    color "#915c31"+    border "1px solid #FFF178"+    rule "pre" $ do+      margin "0"+    rule "h2" $ do+      color "#2D2542"++-- | Paste view styles.+paste :: CSS Rule+paste = do+  classRule "paste-specs" $ do+    margin "0.5em 0 0 0"+    padding "0"+    listStyle "none"+    lineHeight "1.5em"+    +    rule "strong" $ do+      fontWeight "normal"+      width "8em"+      display "block"+      float "left"+  rule ".revisions" $ do+    listStyleType "none"+    paddingLeft "0"+  classRule "paste-nav" $ do+    float "right"++-- | Utility styles to help with HTML weirdness.+utils :: CSS Rule+utils = do+  classRule "clear" $ do+    clear "both"++-- | A short-hand for prefixing rules with ‘.amelie-’.+classRule :: Text -> CSS (Either Property Rule) -> CSS Rule+classRule = rule . (".amelie-" ++)++-- | Styles for the highlighter.+highlighter :: CSS Rule+highlighter = do+  diff++  classRule "steps" $ do+    marginTop "1em"+  classRule "steps-expr" $ do+    rule ".text" $ do+      width "300px"++  classRule "code" $ do+    tokens++    rule "pre" $ do+      margin "0"++    rule "td" $ do+      verticalAlign "top"+  lineNumbers+  +-- | Style for diff groups.+diff :: CSS Rule+diff = do+  classRule "diff-both" $+    return ()+  classRule "diff-first" $ do+    backgroundColor "#FDD"+    color "#695B5B"+  classRule "diff-second" $ do+    backgroundColor "#DFD"++-- | Tokens colours and styles.+tokens :: CSS (Either Property Rule)+tokens = do+  rule "pre" $ do+    marginTop "0"+    tokenColor "comment" "#555"+    tokenColor "keyword" "#397460"+    tokenColor "str" "#366354"+    tokenColor "conid" "#4F4371"+    tokenColor "varop" "#333"+    tokenColor "varid" "#333"+    tokenColor "num" "#4F4371"+  rule "pre" $ do+    rule ".diff" $ do+      color "#555"+    rule "code" $ do+      jcolor "title" "#333"+      jcolor "string" "#366354"+      jcolor "built_in" "#397460"+      jcolor "preprocessor" "#4F4371"+      jcolor "comment" "#555"+      jcolor "command" "#397460"+      jcolor "special" "#333"+      jcolor "formula" "#4F4371"+      jcolor "keyword" "#397460"+      jcolor "number" "#4F4371"+      rule ".header" $ do+        color "#555"+      rule ".deletion" $ do+        backgroundColor "#FDD"+        color "#695B5B"+      rule ".addition" $ do+        backgroundColor "#DFD"+        color "#000"+  where token name props = rule (".hs-" ++ name) $ props+        tokenColor name col = token name $ color col+        jcolor name col = rule ("." ++ name) $ color col++-- | The line number part.+lineNumbers :: CSS Rule+lineNumbers = do+  rule ".amelie-line-nums pre" $ do+    margin "0 1em 0 0"+    textAlign "right"+    rule "a" $ do+      textDecoration "none"+      color "#555"+    rule "a:target" $ do+      textDecoration "underline"+      color "#000"++-- | Home page styles.+home :: CSS Rule+home = do+  rule "#new" wrap+  classRule "browse-link" $ do+    margin "1em 0 0 0"+  classRule "latest-pastes" $ do+    marginTop "0.5em"+  +  where wrap = rule ".amelie-wrap" $ do+                 width "50em"++-- | Browse page styles.+browse :: CSS Rule+browse = do+  rule ".pages-list" $ do+    rule "li" $ do+      display "inline"+      marginRight "1em"+    rule "a.active" $ do+      fontWeight "bold"+      color "#fff"+      cursor "default"++  classRule "pagination" $ do+    textAlign "center"+    margin "1em"++    rule ".amelie-inner" $ do+      margin "auto"+      width "15em"++-- | Developer activity page styles.+activity :: CSS Rule+activity = do+  rule "#activity" $ do+    rule ".amelie-wrap" $ do+      width "50em"++-- | Hlint hints+hints :: CSS Rule+hints = do+  classRule "hint-highlight" $ do+    background "#333"+    color "#999"+    border "1px solid #444"
+ src/Hpaste/View/Thanks.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Thanks view.++module Hpaste.View.Thanks+  (page)+  where++import Hpaste.Types+import Hpaste.View.Html+import Hpaste.View.Layout++import Data.String+import Data.Text              (Text)+import Prelude                hiding ((++))+import Text.Blaze.Html5       as H hiding (map)++-- | Render the thanks5 page.+page :: String -> String -> Html+page title msg =+  layoutPage $ Page {+    pageTitle = fromString title+  , pageBody  = thanks title msg+  , pageName  = "thanks"+  }++thanks :: String -> String -> Html+thanks title msg = do+  darkSection (fromString title) $ do+    p $ toHtml msg+    p $ href ("/" :: Text)+             ("Go back home" :: Text)
+ src/Network/Email.hs view
@@ -0,0 +1,34 @@+module Network.SendEmail where++-- | An email to be sent via SMTP.+data Email =+  Email { emailSMTPHost :: String+        , emailEHLO :: String+        , emailFromName :: String+        , emailToName :: String+        , emailFromEmail :: String+        , emailToEmail :: String+        , emailSubject :: String+        , emailBody :: String+        }++-- | Send an SMTP email.+sendEmail :: (MonadIO m) => Email -> m ()+sendEmail Email{..} =+  io $ do+  addr <- lookupIP emailSMTPHost+  case addr of+    Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg]+    Nothing -> error "Unable to lookup the SMTP IP."+  where msg = SimpleMessage {+                from    = [NameAddr (Just emailFromName) emailFromEmail]+              , to      = [NameAddr (Just emailToName) emailToEmail]+              , subject = emailSubject+              , body    = emailBody+              }+        -- | Look up the IP address for the SMTP server.+        lookupIP :: MonadIO m => String -> m (Maybe String)+        lookupIP domain = io $ do+          let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }+          addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp")+          return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs
+ src/Network/SendEmail.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RecordWildCards #-}++-- | Simple module for sending emails.++module Network.SendEmail where++import Control.Monad.IO+import Control.Monad.Trans+import Data.Maybe+import Network.SMTP.Simple+import Network.Socket++-- | An email to be sent via SMTP.+data Email =+  Email { emailSMTPHost :: String+        , emailEHLO :: String+        , emailFromName :: String+        , emailToName :: String+        , emailFromEmail :: String+        , emailToEmail :: String+        , emailSubject :: String+        , emailBody :: String+        }++-- | Send an SMTP email.+sendEmail :: (MonadIO m) => Email -> m ()+sendEmail Email{..} =+  io $ do+  addr <- lookupIP emailSMTPHost+  case addr of+    Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg]+    Nothing -> error "Unable to lookup the SMTP IP."+  where msg = SimpleMessage {+                from    = [NameAddr (Just emailFromName) emailFromEmail]+              , to      = [NameAddr (Just emailToName) emailToEmail]+              , subject = emailSubject+              , body    = emailBody+              }+        -- | Look up the IP address for the SMTP server.+        lookupIP :: MonadIO m => String -> m (Maybe String)+        lookupIP domain = io $ do+          let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }+          addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp")+          return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs
+ src/Network/URI/Params.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS -fno-warn-missing-signatures #-}+module Network.URI.Params (updateUrlParam,updateUrlParams,uriParams,deleteQueryKey) where++import Control.Arrow+import Network.URI+import Data.List+import Data.Function+import Network.CGI++updateUrlParam :: String -> String -> URI -> URI+updateUrlParam this value uri@(URI{uriQuery}) =+  uri { uriQuery = updated uriQuery } where+  updated = editQuery $ ((this,value):) . deleteBy ((==) `on` fst) (this,"")++deleteQueryKey :: String -> URI -> URI+deleteQueryKey key uri =+  uri { uriQuery = editQuery (filter ((/=key).fst)) (uriQuery uri) }++editQuery :: ([(String,String)] -> [(String,String)]) -> String -> String+editQuery f = ('?':) . formEncodeUrl . f . formDecode . dropWhile (=='?')++formEncodeUrl = intercalate "&" . map keyval . map (esc *** esc)+  where keyval (key,val) = key ++ "=" ++ val+        esc = escapeURIString isAllowedInURI++updateUrlParams :: [(String,String)] -> URI -> URI+updateUrlParams = flip $ foldr $ uncurry updateUrlParam++uriParams :: URI -> [(String,String)]+uriParams = formDecode . dropWhile (=='?') . uriQuery
+ src/Snap/App.hs view
@@ -0,0 +1,11 @@+module Snap.App+  (module Snap.Core+  ,module Snap.App.Types+  ,module Snap.App.Controller+  ,module Snap.App.Model)+  where++import Snap.Core+import Snap.App.Types+import Snap.App.Controller+import Snap.App.Model
+ src/Text/Blaze/Html5/Extra.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.Blaze.Html5.Extra where++import           Text.Blaze.Html5            as H+import qualified Text.Blaze.Html5.Attributes as A++-- | A POST form.+postForm :: Html -> Html+postForm = H.form ! A.method "POST"