| By | Chris Done |
| At | 2011-08-12 |
| Title | Reporting support. |
| Description |
Edit file SQLCHANGES 33188 → 33188
1 1 CREATE TABLE hint (id serial primary key, paste integer references
2 2 paste(id) on delete cascade on update cascade, type text not null,
3 3 content text not null);
+ 4 + 5 create table report (id serial primary key, paste integer not null
+ 6 references paste(id) on delete cascade on update cascade, comments
+ 7 text not null);
… … … … Edit file amelie.cabal 33188 → 33188
11 11 Build-type: Simple
12 12 Cabal-version: >=1.2
13 13 14 14 Executable amelie
15 15 Main-is: Main.hs
- 16 Ghc-options: -threaded -O2
+ 16 Ghc-options: -threaded
17 17 Hs-source-dirs: src
- 18 Build-depends: base >= 4 && < 5
- 19 ,snap-server >= 0.4 && < 0.5
- 20 ,snap-core >= 0.4 && < 0.5
- 21 ,text >= 0.11 && < 0.12
- 22 ,blaze-html >= 0.4 && < 0.5
- 23 ,bytestring >= 0.9 && < 0.10
- 24 ,containers >= 0.3 && < 0.4
- 25 ,mtl >= 2.0 && < 2.1
- 26 ,transformers >= 0.2 && < 0.3
- 27 ,utf8-string >= 0.3 && < 0.4
- 28 ,pgsql-simple >= 0.1.1
- 29 ,network >= 2.3 && < 2.4
- 30 ,MonadCatchIO-transformers >= 0.2 && < 0.3
- 31 ,time >= 1.1
- 32 ,old-locale >= 1.0
- 33 ,safe >= 0.3
- 34 ,hscolour >= 1.17
- 35 ,HJScript >= 0.5
- 36 ,hlint >= 1.8
- 37 ,filepath >= 1.1
- 38 ,directory >= 1.0
- 39 ,blaze-builder >= 0.2
- 40 ,ConfigFile >= 1.0
- 41 ,feed >= 0.3
- 42 ,download-curl >= 0.1
- 43 ,Diff >= 0.1
- 44 ,css >= 0.1
- 45 ,named-formlet >= 0.1
- 46 ,stepeval >= 0.2
- 47 ,haskell-src-exts >= 1.10
+ 18 Build-depends: base >= 4 && < 5
+ 19 ,snap-server >= 0.4 && < 0.5
+ 20 ,snap-core >= 0.4 && < 0.5
+ 21 ,text >= 0.11 && < 0.12
+ 22 ,blaze-html >= 0.4 && < 0.5
+ 23 ,bytestring >= 0.9 && < 0.10
+ 24 ,containers >= 0.3 && < 0.4
+ 25 ,mtl >= 2.0 && < 2.1
+ 26 ,transformers >= 0.2 && < 0.3
+ 27 ,utf8-string >= 0.3 && < 0.4
+ 28 ,pgsql-simple >= 0.1.1
+ 29 ,network >= 2.3 && < 2.4
+ 30 ,MonadCatchIO-transformers >= 0.2 && < 0.3
+ 31 ,time >= 1.1
+ 32 ,old-locale >= 1.0
+ 33 ,safe >= 0.3
+ 34 ,hscolour >= 1.17
+ 35 ,HJScript >= 0.5
+ 36 ,hlint >= 1.8
+ 37 ,filepath >= 1.1
+ 38 ,directory >= 1.0
+ 39 ,blaze-builder >= 0.2
+ 40 ,ConfigFile >= 1.0
+ 41 ,feed >= 0.3
+ 42 ,download-curl >= 0.1
+ 43 ,Diff >= 0.1
+ 44 ,css >= 0.1
+ 45 ,named-formlet >= 0.1
+ 46 ,stepeval >= 0.2
+ 47 ,haskell-src-exts >= 1.10
+ 48 … … … … Edit file src/Main.hs 33188 → 33188
13 13 import Amelie.Controller.Diff as Diff
14 14 import Amelie.Controller.Home as Home
15 15 import Amelie.Controller.New as New
16 16 import Amelie.Controller.Paste as Paste
17 17 import Amelie.Controller.Raw as Raw
+ 18 import Amelie.Controller.Report as Report
18 19 import Amelie.Controller.Script as Script
19 20 import Amelie.Controller.Stepeval as Stepeval
20 21 import Amelie.Controller.Steps as Steps
21 22 import Amelie.Controller.Style as Style
22 23 import Amelie.Model.Announcer (newAnnouncer)
… … … … 82 83 -- @ next pastePage
83 84 ,("/steps/:id",run Steps.handle)84 85 -- @ next stepsPage
85 86 ,("/raw/:id",run Raw.handle)86 87 -- @ next rawPastePage
+ 88 ,("/report/:id",run Report.handle)+ 89 -- @ next reportPastePage
87 90 ,("/new",run New.handle)88 91 -- @ next newPastePage
89 92 ,("/edit/:id",run New.handle)90 93 -- @ next annotatePage
91 94 ,("/new/:channel",run New.handle)… … … … Edit file src/Amelie/Types.hs 33188 → 33188
23 23 import Amelie.Types.Newtypes
24 24 import Amelie.Types.View
25 25 import Amelie.Types.Config
26 26 import Amelie.Types.Activity
27 27 import Amelie.Types.Stepeval
+ 28 … … … … Edit file src/Amelie/View/Paste.hs 33188 → 33188
- 1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}2 2 {-# LANGUAGE OverloadedStrings #-}3 3 {-# LANGUAGE RecordWildCards #-}4 4 5 5 -- | Paste views.
6 6 … … … … 146 146 pasteNav langs pastes paste =
147 147 H.div ! aClass "paste-nav" $ do
148 148 diffLink
149 149 stepsLink
150 150 href ("/edit/" ++ pack (show pid) ++ "") ("Annotate" :: Text)+ 151 " - "
+ 152 href ("/report/" ++ pack (show pid) ++ "") ("Report/Delete" :: Text)151 153 152 154 where pid = pasteId paste
153 155 pairs = zip (drop 1 pastes) pastes
154 156 parent = fmap snd $ find ((==pid).pasteId.fst) $ pairs
155 157 diffLink =
… … … … Edit file src/Amelie/Types/Newtypes.hs 33188 → 33188
4 4 -- | Newtypes; foreign keys and such.
5 5 6 6 module Amelie.Types.Newtypes
7 7 (PasteId(..)
8 8 ,ChannelId(..)
- 9 ,LanguageId(..))
+ 9 ,LanguageId(..)
+ 10 ,ReportId(..))
10 11 where
11 12 12 13 import Database.PostgreSQL.Simple.Result (Result)
13 14 import Database.PostgreSQL.Simple.Param (Param)
14 15 15 16 newtype PasteId = PasteId Integer
16 17 deriving (Integral,Real,Num,Ord,Eq,Enum,Result,Param)
17 18 18 19 instance Show PasteId where show (PasteId pid) = show pid
+ 20 + 21 newtype ReportId = ReportId Integer
+ 22 deriving (Integral,Real,Num,Ord,Eq,Enum,Result,Param)
+ 23 + 24 instance Show ReportId where show (ReportId pid) = show pid
19 25 20 26 newtype ChannelId = ChannelId Integer
21 27 deriving (Integral,Real,Num,Ord,Eq,Enum,Result,Param)
22 28 23 29 instance Show ChannelId where show (ChannelId pid) = show pid
… … … … Edit file src/Amelie/Types/Paste.hs 33188 → 33188
10 10 ,PasteSubmit(..)
11 11 ,PasteFormlet(..)
12 12 ,ExprFormlet(..)
13 13 ,PastePage(..)
14 14 ,StepsPage(..)
- 15 ,Hint(..))
+ 15 ,Hint(..)
+ 16 ,ReportFormlet(..)
+ 17 ,ReportSubmit(..))
16 18 where
17 19 18 20 import Amelie.Types.Newtypes
19 21 import Amelie.Types.Language
20 22 import Amelie.Types.Channel
… … … … 126 128 convertResults field values = Hint {127 129 hintType = severity
128 130 , hintContent = content
129 131 }
130 132 where (severity,content) = convertResults field values
+ 133 + 134 data ReportFormlet = ReportFormlet {+ 135 rfSubmitted :: Bool
+ 136 , rfParams :: Params
+ 137 }
+ 138 + 139 data ReportSubmit = ReportSubmit {+ 140 rsPaste :: PasteId
+ 141 ,rsComments :: String
+ 142 }
… … … … Edit file src/Amelie/Controller/Cache.hs 33188 → 33188
9 9 where
10 10 11 11 import Amelie.Types
12 12 import Amelie.Types.Cache
13 13 - 14 import Control.Applicative ((<$>))
15 14 import Control.Concurrent
16 15 import Control.Monad.IO (io)
17 16 import Control.Monad.Reader (asks)
18 17 import qualified Data.Map as M
19 18 import Data.Text.Lazy (Text)
… … … … 27 26 return $ Cache var
28 27 29 28 cache :: Key -> Controller (Maybe Html) -> Controller (Maybe Text)
30 29 cache _key generate = fmap (fmap renderHtml) generate
31 30 - 32 -- | Generate and save into the cache, or retrieve existing from the
- 33 -- | cache.
- 34 cache' :: Key -> Controller (Maybe Html) -> Controller (Maybe Text)
- 35 cache' key generate = do
- 36 Cache var <- asks controllerStateCache
- 37 mapping <- io $ readMVar var
- 38 case M.lookup key mapping of
- 39 Just html -> return $ Just html
- 40 Nothing -> do
- 41 html <- fmap renderHtml <$> generate
- 42 case html of
- 43 Just html -> io $ modifyMVar_ var (return . M.insert key html)
- 44 Nothing -> return ()
- 45 return $ html
+ 31 -- -- | Generate and save into the cache, or retrieve existing from the
+ 32 -- -- | cache.
+ 33 -- cache' :: Key -> Controller (Maybe Html) -> Controller (Maybe Text)
+ 34 -- cache' key generate = do
+ 35 -- Cache var <- asks controllerStateCache
+ 36 -- mapping <- io $ readMVar var
+ 37 -- case M.lookup key mapping of
+ 38 -- Just html -> return $ Just html
+ 39 -- Nothing -> do
+ 40 -- html <- fmap renderHtml <$> generate
+ 41 -- case html of
+ 42 -- Just html -> io $ modifyMVar_ var (return . M.insert key html)
+ 43 -- Nothing -> return ()
+ 44 -- return $ html
46 45 47 46 -- | Reset an item in the cache.
48 47 resetCache :: Key -> Controller ()
49 48 resetCache key = do
50 49 Cache var <- asks controllerStateCache
… … … … Edit file src/Amelie/Controller/Steps.hs 33188 → 33188
7 7 module Amelie.Controller.Steps
8 8 (handle)
9 9 where
10 10 11 11 import Amelie.Types
- 12 13 12 import Amelie.Controller
14 13 import Amelie.Controller.Paste (getPasteId)
15 14 import Amelie.Controller.Cache (cache)
16 15 import Amelie.Model
17 16 import Amelie.Model.Channel (getChannels)
… … … … Add file src/Network/Email.hs 33188
+ 1 module Network.SendEmail where + 2 + 3 -- | An email to be sent via SMTP. + 4 data Email = + 5 Email { emailSMTPHost :: String + 6 , emailEHLO :: String + 7 , emailFromName :: String + 8 , emailToName :: String + 9 , emailFromEmail :: String + 10 , emailToEmail :: String + 11 , emailSubject :: String + 12 , emailBody :: String + 13 } + 14 + 15 -- | Send an SMTP email. + 16 sendEmail :: (MonadIO m) => Email -> m () + 17 sendEmail Email{..} = + 18 io $ do + 19 addr <- lookupIP emailSMTPHost + 20 case addr of + 21 Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg] + 22 Nothing -> error "Unable to lookup the SMTP IP." + 23 where msg = SimpleMessage { + 24 from = [NameAddr (Just emailFromName) emailFromEmail] + 25 , to = [NameAddr (Just emailToName) emailToEmail] + 26 , subject = emailSubject + 27 , body = emailBody + 28 } + 29 -- | Look up the IP address for the SMTP server. + 30 lookupIP :: MonadIO m => String -> m (Maybe String) + 31 lookupIP domain = io $ do + 32 let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } + 33 addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp") + 34 return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs Add file src/Network/SendEmail.hs 33188
+ 1 {-# LANGUAGE RecordWildCards #-} + 2 + 3 -- | Simple module for sending emails. + 4 + 5 module Network.SendEmail where + 6 + 7 import Control.Monad.IO + 8 import Control.Monad.Trans + 9 import Data.Maybe + 10 import Network.SMTP.Simple + 11 import Network.Socket + 12 + 13 -- | An email to be sent via SMTP. + 14 data Email = + 15 Email { emailSMTPHost :: String + 16 , emailEHLO :: String + 17 , emailFromName :: String + 18 , emailToName :: String + 19 , emailFromEmail :: String + 20 , emailToEmail :: String + 21 , emailSubject :: String + 22 , emailBody :: String + 23 } + 24 + 25 -- | Send an SMTP email. + 26 sendEmail :: (MonadIO m) => Email -> m () + 27 sendEmail Email{..} = + 28 io $ do + 29 addr <- lookupIP emailSMTPHost + 30 case addr of + 31 Just ip -> sendSimpleMessages putStrLn ip emailEHLO [msg] + 32 Nothing -> error "Unable to lookup the SMTP IP." + 33 where msg = SimpleMessage { + 34 from = [NameAddr (Just emailFromName) emailFromEmail] + 35 , to = [NameAddr (Just emailToName) emailToEmail] + 36 , subject = emailSubject + 37 , body = emailBody + 38 } + 39 -- | Look up the IP address for the SMTP server. + 40 lookupIP :: MonadIO m => String -> m (Maybe String) + 41 lookupIP domain = io $ do + 42 let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } + 43 addrs <- getAddrInfo (Just hints) (Just domain) (Just "smtp") + 44 return $ listToMaybe $ map (takeWhile (/=':') . show . addrAddress) addrs Add file src/Amelie/View/Report.hs 33188
+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# LANGUAGE RecordWildCards #-} + 4 + 5 -- | Report view. + 6 + 7 module Amelie.View.Report + 8 (page,reportFormlet) + 9 where + 10 + 11 import Amelie.Types + 12 import Amelie.View.Highlight + 13 import Amelie.View.Html + 14 import Amelie.View.Layout + 15 + 16 import Data.Monoid.Operator ((++)) + 17 import Data.Text (Text) + 18 import Prelude hiding ((++)) + 19 import Text.Blaze.Html5 as H hiding (map) + 20 import qualified Text.Blaze.Html5.Attributes as A + 21 import Text.Formlet + 22 + 23 -- | Render the page page. + 24 page :: Html -> Paste -> Html + 25 page form paste = + 26 layoutPage $ Page { + 27 pageTitle = "Report a paste" + 28 , pageBody = do reporting form; viewPaste paste + 29 , pageName = "paste" + 30 } + 31 + 32 reporting :: Html -> Html + 33 reporting form = do + 34 lightSection "Report a paste" $ do + 35 p $ do "Please state any comments regarding the paste:" + 36 H.form ! A.method "post" $ do + 37 form + 38 + 39 -- | View a paste's details and content. + 40 viewPaste :: Paste -> Html + 41 viewPaste Paste{..} = do + 42 pasteDetails pasteTitle + 43 pasteContent pastePaste + 44 + 45 -- | List the details of the page in a dark section. + 46 pasteDetails :: Text -> Html + 47 pasteDetails title = + 48 darkNoTitleSection $ do + 49 pasteNav + 50 h2 $ toHtml title + 51 ul ! aClass "paste-specs" $ do + 52 detail "Language" $ "Haskell" + 53 detail "Raw" $ href ("/stepeval/raw" :: Text) + 54 ("View raw link" :: Text) + 55 clear + 56 + 57 where detail title content = do + 58 li $ do strong (title ++ ":"); content + 59 + 60 -- | Individual paste navigation. + 61 pasteNav :: Html + 62 pasteNav = + 63 H.div ! aClass "paste-nav" $ do + 64 href ("https://github.com/benmachine/stepeval" :: Text) + 65 ("Go to stepeval project" :: Text) + 66 + 67 -- | Show the paste content with highlighting. + 68 pasteContent :: Text -> Html + 69 pasteContent paste = + 70 lightNoTitleSection $ + 71 highlightHaskell paste + 72 + 73 -- | A formlet for report submission / editing. + 74 reportFormlet :: ReportFormlet -> (Formlet Text,Html) + 75 reportFormlet ReportFormlet{..} = + 76 let frm = form $ do + 77 formletHtml reportSubmit rfParams + 78 submitInput "submit" "Submit" + 79 in (reportSubmit,frm) + 80 + 81 reportSubmit :: Formlet Text + 82 reportSubmit = req (textInput "report" "Comments" Nothing) Add file src/Amelie/View/Thanks.hs 33188
+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# LANGUAGE RecordWildCards #-} + 4 + 5 -- | Thanks view. + 6 + 7 module Amelie.View.Thanks + 8 (page) + 9 where + 10 + 11 import Amelie.Types + 12 import Amelie.View.Html + 13 import Amelie.View.Layout + 14 + 15 import Data.String + 16 import Data.Text (Text) + 17 import Prelude hiding ((++)) + 18 import Text.Blaze.Html5 as H hiding (map) + 19 + 20 -- | Render the thanks5 page. + 21 page :: String -> String -> Html + 22 page title msg = + 23 layoutPage $ Page { + 24 pageTitle = fromString title + 25 , pageBody = thanks title msg + 26 , pageName = "thanks" + 27 } + 28 + 29 thanks :: String -> String -> Html + 30 thanks title msg = do + 31 darkSection (fromString title) $ do + 32 p $ toHtml msg + 33 p $ href ("/" :: Text) + 34 ("Go back home" :: Text) Add file src/Amelie/Model/Report.hs 33188
+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# LANGUAGE RecordWildCards #-} + 4 {-# LANGUAGE ScopedTypeVariables #-} + 5 {-# LANGUAGE ViewPatterns #-} + 6 + 7 -- | Report model. + 8 + 9 module Amelie.Model.Report + 10 (getReports,createReport) + 11 where + 12 + 13 import Amelie.Types + 14 import Amelie.Model + 15 + 16 import Control.Monad + 17 import Prelude hiding ((++)) + 18 + 19 -- @ label getReports + 20 -- @ task Get reports. + 21 -- | Get the reports. + 22 getReports :: Model [Paste] + 23 getReports = + 24 queryNoParams ["SELECT *" + 25 ,"FROM report" + 26 ,"ORDER BY id DESC" + 27 ,"LIMIT 20"] + 28 + 29 -- @ label createReport + 30 -- @ task Create report. + 31 -- | Create a new report. + 32 createReport :: ReportSubmit -> Model (Maybe ReportId) + 33 createReport ReportSubmit{..} = do + 34 res <- single ["INSERT INTO report" + 35 ,"(paste,comments)" + 36 ,"VALUES" + 37 ,"(?,?)" + 38 ,"returning id"] + 39 (rsPaste,rsComments) + 40 return res Add file src/Amelie/Controller/Report.hs 33188
+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# LANGUAGE ScopedTypeVariables #-} + 4 {-# LANGUAGE RecordWildCards #-} + 5 + 6 -- | Report controller. + 7 + 8 module Amelie.Controller.Report + 9 (handle) + 10 where + 11 + 12 import Amelie.Controller + 13 import Amelie.Model + 14 import Amelie.Model.Paste (getPasteById) + 15 import Amelie.Model.Report + 16 import Amelie.Types + 17 import Amelie.View.Report + 18 import qualified Amelie.View.Thanks as Thanks + 19 + 20 import Control.Applicative + 21 import Data.ByteString.UTF8 (toString) + 22 import Data.Maybe + 23 import Data.Monoid.Operator ((++)) + 24 import Data.Text (unpack) + 25 import Prelude hiding ((++)) + 26 import Safe + 27 import Snap.Types + 28 import Text.Blaze.Html5 as H hiding (output,map,body) + 29 import Text.Formlet + 30 + 31 -- | Handle the report/delete page. + 32 handle :: Controller () + 33 handle = do + 34 pid <- (>>= readMay) . fmap (toString) <$> getParam "id" + 35 case pid of + 36 Nothing -> goHome + 37 Just (pid :: Integer) -> do + 38 paste <- model $ getPasteById (fromIntegral pid) + 39 (frm,val) <- exprForm + 40 case val of + 41 Just comment -> do + 42 _ <- model $ createReport ReportSubmit { rsPaste = fromIntegral pid + 43 , rsComments = comment } + 44 output $ Thanks.page "Reported" $ + 45 "Thanks, your comments have " ++ + 46 "been reported to the administrator." + 47 Nothing -> maybe goHome (output . page frm) paste + 48 + 49 -- | Report form. + 50 exprForm :: Controller (Html,Maybe String) + 51 exprForm = do + 52 params <- getParams + 53 submitted <- isJust <$> getParam "submit" + 54 let formlet = ReportFormlet { + 55 rfSubmitted = submitted + 56 , rfParams = params + 57 } + 58 (getValue,_) = reportFormlet formlet + 59 value = formletValue getValue params + 60 (_,html) = reportFormlet formlet + 61 val = either (const Nothing) Just $ value + 62 return (html,fmap unpack val)