diff --git a/hpaste.cabal b/hpaste.cabal
--- a/hpaste.cabal
+++ b/hpaste.cabal
@@ -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
diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Catch.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
+module Control.Monad.Catch (module Control.Monad.CatchIO) where
+
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
diff --git a/src/Control/Monad/Env.hs b/src/Control/Monad/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Env.hs
@@ -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
diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/IO.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS -Wall #-}
+
+module Control.Monad.IO where
+
+import Control.Monad.Trans
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
diff --git a/src/Data/Either/Extra.hs b/src/Data/Either/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Either/Extra.hs
@@ -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 ()
diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Maybe/Extra.hs
@@ -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 ()
diff --git a/src/Data/Monoid/Operator.hs b/src/Data/Monoid/Operator.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Monoid/Operator.hs
@@ -0,0 +1,8 @@
+-- | Convenient operator.
+
+module Data.Monoid.Operator where
+
+import Data.Monoid
+
+(++) :: (Monoid a) => a -> a -> a
+(++) = mappend
diff --git a/src/Data/String/Extra.hs b/src/Data/String/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/String/Extra.hs
@@ -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
diff --git a/src/Data/String/ToString.hs b/src/Data/String/ToString.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/String/ToString.hs
@@ -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
diff --git a/src/Data/Text/FromText.hs b/src/Data/Text/FromText.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Text/FromText.hs
@@ -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
diff --git a/src/Data/Text/ToText.hs b/src/Data/Text/ToText.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Text/ToText.hs
@@ -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
diff --git a/src/Data/Time/Show.hs b/src/Data/Time/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Time/Show.hs
@@ -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
diff --git a/src/HJScript/Objects/JQuery/Extra.hs b/src/HJScript/Objects/JQuery/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/HJScript/Objects/JQuery/Extra.hs
@@ -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)
diff --git a/src/Hpaste/Config.hs b/src/Hpaste/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Config.hs
@@ -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
diff --git a/src/Hpaste/Controller/Activity.hs b/src/Hpaste/Controller/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Activity.hs
@@ -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
diff --git a/src/Hpaste/Controller/Admin.hs b/src/Hpaste/Controller/Admin.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Admin.hs
@@ -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
diff --git a/src/Hpaste/Controller/Browse.hs b/src/Hpaste/Controller/Browse.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Browse.hs
@@ -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
diff --git a/src/Hpaste/Controller/Cache.hs b/src/Hpaste/Controller/Cache.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Cache.hs
@@ -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"
diff --git a/src/Hpaste/Controller/Diff.hs b/src/Hpaste/Controller/Diff.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Diff.hs
@@ -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
diff --git a/src/Hpaste/Controller/Home.hs b/src/Hpaste/Controller/Home.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Home.hs
@@ -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
diff --git a/src/Hpaste/Controller/Irclogs.hs b/src/Hpaste/Controller/Irclogs.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Irclogs.hs
@@ -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)
diff --git a/src/Hpaste/Controller/New.hs b/src/Hpaste/Controller/New.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/New.hs
@@ -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
diff --git a/src/Hpaste/Controller/Paste.hs b/src/Hpaste/Controller/Paste.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Paste.hs
@@ -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 ()
diff --git a/src/Hpaste/Controller/Raw.hs b/src/Hpaste/Controller/Raw.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Raw.hs
@@ -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
diff --git a/src/Hpaste/Controller/Report.hs b/src/Hpaste/Controller/Report.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Report.hs
@@ -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))
diff --git a/src/Hpaste/Controller/Reported.hs b/src/Hpaste/Controller/Reported.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Reported.hs
@@ -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
diff --git a/src/Hpaste/Controller/Script.hs b/src/Hpaste/Controller/Script.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Script.hs
@@ -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
diff --git a/src/Hpaste/Controller/Style.hs b/src/Hpaste/Controller/Style.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Controller/Style.hs
@@ -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
diff --git a/src/Hpaste/Model/Activity.hs b/src/Hpaste/Model/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Activity.hs
@@ -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"
diff --git a/src/Hpaste/Model/Announcer.hs b/src/Hpaste/Model/Announcer.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Announcer.hs
@@ -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)
diff --git a/src/Hpaste/Model/Channel.hs b/src/Hpaste/Model/Channel.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Channel.hs
@@ -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"]
diff --git a/src/Hpaste/Model/Irclogs.hs b/src/Hpaste/Model/Irclogs.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Irclogs.hs
@@ -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))
diff --git a/src/Hpaste/Model/Language.hs b/src/Hpaste/Model/Language.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Language.hs
@@ -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"]
diff --git a/src/Hpaste/Model/Paste.hs b/src/Hpaste/Model/Paste.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Paste.hs
@@ -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"
diff --git a/src/Hpaste/Model/Report.hs b/src/Hpaste/Model/Report.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Report.hs
@@ -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
diff --git a/src/Hpaste/Model/Spam.hs b/src/Hpaste/Model/Spam.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Model/Spam.hs
@@ -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
diff --git a/src/Hpaste/Types.hs b/src/Hpaste/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types.hs
@@ -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
diff --git a/src/Hpaste/Types/Activity.hs b/src/Hpaste/Types/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Activity.hs
@@ -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
diff --git a/src/Hpaste/Types/Announcer.hs b/src/Hpaste/Types/Announcer.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Announcer.hs
@@ -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
+ }
diff --git a/src/Hpaste/Types/Cache.hs b/src/Hpaste/Types/Cache.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Cache.hs
@@ -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)
+ }
diff --git a/src/Hpaste/Types/Channel.hs b/src/Hpaste/Types/Channel.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Channel.hs
@@ -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
diff --git a/src/Hpaste/Types/Config.hs b/src/Hpaste/Types/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Config.hs
@@ -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
+
diff --git a/src/Hpaste/Types/Language.hs b/src/Hpaste/Types/Language.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Language.hs
@@ -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
diff --git a/src/Hpaste/Types/Newtypes.hs b/src/Hpaste/Types/Newtypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Newtypes.hs
@@ -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
diff --git a/src/Hpaste/Types/Page.hs b/src/Hpaste/Types/Page.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Page.hs
@@ -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
+ }
diff --git a/src/Hpaste/Types/Paste.hs b/src/Hpaste/Types/Paste.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Paste.hs
@@ -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
+}
diff --git a/src/Hpaste/Types/Report.hs b/src/Hpaste/Types/Report.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Report.hs
@@ -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
diff --git a/src/Hpaste/Types/Stepeval.hs b/src/Hpaste/Types/Stepeval.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/Types/Stepeval.hs
@@ -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]
+}
diff --git a/src/Hpaste/View/Activity.hs b/src/Hpaste/View/Activity.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Activity.hs
@@ -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)
diff --git a/src/Hpaste/View/Annotate.hs b/src/Hpaste/View/Annotate.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Annotate.hs
@@ -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"
+ }
diff --git a/src/Hpaste/View/Browse.hs b/src/Hpaste/View/Browse.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Browse.hs
@@ -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"
diff --git a/src/Hpaste/View/Diff.hs b/src/Hpaste/View/Diff.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Diff.hs
@@ -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)
diff --git a/src/Hpaste/View/Edit.hs b/src/Hpaste/View/Edit.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Edit.hs
@@ -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"
+ }
diff --git a/src/Hpaste/View/Highlight.hs b/src/Hpaste/View/Highlight.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Highlight.hs
@@ -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)
diff --git a/src/Hpaste/View/Hlint.hs b/src/Hpaste/View/Hlint.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Hlint.hs
@@ -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)
diff --git a/src/Hpaste/View/Home.hs b/src/Hpaste/View/Home.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Home.hs
@@ -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)
diff --git a/src/Hpaste/View/Html.hs b/src/Hpaste/View/Html.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Html.hs
@@ -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
diff --git a/src/Hpaste/View/Irclogs.hs b/src/Hpaste/View/Irclogs.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Irclogs.hs
@@ -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)
diff --git a/src/Hpaste/View/Layout.hs b/src/Hpaste/View/Layout.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Layout.hs
@@ -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 ""
+
+ 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
diff --git a/src/Hpaste/View/New.hs b/src/Hpaste/View/New.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/New.hs
@@ -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"
+ }
diff --git a/src/Hpaste/View/Paste.hs b/src/Hpaste/View/Paste.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Paste.hs
@@ -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
diff --git a/src/Hpaste/View/Report.hs b/src/Hpaste/View/Report.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Report.hs
@@ -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)
diff --git a/src/Hpaste/View/Reported.hs b/src/Hpaste/View/Reported.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Reported.hs
@@ -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
diff --git a/src/Hpaste/View/Script.hs b/src/Hpaste/View/Script.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Script.hs
@@ -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 "Expand")
+ 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"
diff --git a/src/Hpaste/View/Stepeval.hs b/src/Hpaste/View/Stepeval.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Stepeval.hs
@@ -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
diff --git a/src/Hpaste/View/Steps.hs b/src/Hpaste/View/Steps.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Steps.hs
@@ -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)
diff --git a/src/Hpaste/View/Style.hs b/src/Hpaste/View/Style.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Style.hs
@@ -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"
diff --git a/src/Hpaste/View/Thanks.hs b/src/Hpaste/View/Thanks.hs
new file mode 100644
--- /dev/null
+++ b/src/Hpaste/View/Thanks.hs
@@ -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)
diff --git a/src/Network/Email.hs b/src/Network/Email.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Email.hs
@@ -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
diff --git a/src/Network/SendEmail.hs b/src/Network/SendEmail.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/SendEmail.hs
@@ -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
diff --git a/src/Network/URI/Params.hs b/src/Network/URI/Params.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/URI/Params.hs
@@ -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
diff --git a/src/Snap/App.hs b/src/Snap/App.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/App.hs
@@ -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
diff --git a/src/Text/Blaze/Html5/Extra.hs b/src/Text/Blaze/Html5/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Blaze/Html5/Extra.hs
@@ -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"