By | Chris Done |
At | 2011-11-29 |
Title | Add IRC logs. |
Description |
Edit file amelie.cabal 33188 → 33188
43 43 ,Diff >= 0.1
44 44 ,css >= 0.1
45 45 ,named-formlet >= 0.1
46 46 ,stepeval >= 0.2
47 47 ,haskell-src-exts >= 1.10
- 48 + 48 ,MissingH
… … … … Edit file src/Main.hs 33188 → 33188
10 10 import Amelie.Controller.Activity as Activity
11 11 import Amelie.Controller.Browse as Browse
12 12 import Amelie.Controller.Cache (newCache)
13 13 import Amelie.Controller.Diff as Diff
14 14 import Amelie.Controller.Home as Home
+ 15 import Amelie.Controller.Irclogs as Irclogs
15 16 import Amelie.Controller.New as New
16 17 import Amelie.Controller.Paste as Paste
17 18 import Amelie.Controller.Raw as Raw
18 19 import Amelie.Controller.Report as Report
19 20 import Amelie.Controller.Reported as Reported
… … … … 74 75 ("/css/amelie.css", run Style.handle)
75 76 ,("/js/amelie.js", run Script.handle)
76 77 ,("/css/",serveDirectory "wwwroot/css")
77 78 ,("/js/",serveDirectory "wwwroot/js")
78 79 ,("/hs/",serveDirectory "wwwroot/hs")
+ 80 ,("/irc/:channel/:date/:timestamp",run Irclogs.handle)
+ 81 -- /irc/haskell/2011-08-30/00-01-51
+ 82 -- ,("/irc/:channel/:date",run Irclogs.handle)
+ 83 -- ,("/irc/:channel",run Irclogs.handle)
+ 84 -- ,("/irc",run Irclogs.handle)
79 85 -- @ label pageServe
80 86 -- @ do Serve page.
81 87 ,("",run Home.handle)
82 88 -- @ next homePage
83 89 ,("/:id",run Paste.handle)
… … … … Edit file src/Amelie/Config.hs 33188 → 33188
29 29 <- mapM (get c "DEV")
30 30 ["commits","repo_url"]
31 31 [prelude]
32 32 <- mapM (get c "STEPEVAL")
33 33 ["prelude"]
+ 34 [ircDir]
+ 35 <- mapM (get c "IRC")
+ 36 ["log_dir"]
34 37 35 38 return Config {
36 39 configAnnounce = Announcer user pass host (read port)
37 40 , configPostgres = ConnectInfo pghost (read pgport) pguser pgpass pgdb
38 41 , configDomain = domain
39 42 , configCommits = commits
40 43 , configRepoURL = url
41 44 , configStepevalPrelude = prelude
+ 45 , configIrcDir = ircDir
42 46 }
43 47 case config of
44 48 Left cperr -> error $ show cperr
45 49 Right config -> return config
… … … … Edit file src/Amelie/View/Paste.hs 33188 → 33188
9 9 ,page
10 10 ,pasteLink
11 11 ,pasteRawLink)
12 12 where
13 13 + 14 import Amelie.Model.Irclogs (showIrcDateTime)
14 15 import Amelie.Types
15 16 import Amelie.View.Highlight (highlightPaste)
16 17 import Amelie.View.Hlint (viewHints)
17 18 import Amelie.View.Html
18 19 import Amelie.View.Layout
… … … … 131 132 h2 $ toHtml $ fromStrict pasteTitle
132 133 ul ! aClass "paste-specs" $ do
133 134 detail "Paste" $ pasteLink paste $ "#" ++ show pasteId
134 135 detail "Author" $ pasteAuthor
135 136 detail "Language" $ showLanguage langs pasteLanguage
- 136 detail "Channel" $ showChannel chans pasteChannel
+ 137 detail "Channel" $ do showChannel chans pasteChannel
+ 138 showContextLink paste chans pasteChannel
137 139 detail "Created" $ showDateTime pasteDate
138 140 detail "Raw" $ pasteRawLink paste $ ("View raw link" :: Text)
139 141 clear
140 142 141 143 where detail title content = do
142 144 li $ do strong (title ++ ":"); toHtml content
+ 145 + 146 showContextLink :: Paste -> [Channel] -> Maybe ChannelId -> Html
+ 147 showContextLink Paste{..} chans chid =
+ 148 case chid >>= \chid -> find ((==chid).channelId) chans of
+ 149 Nothing -> return ()
+ 150 Just Channel{..} -> do
+ 151 let uri = "/irc/" ++ T.unpack (T.dropWhile (=='#') channelName) ++
+ 152 "/" ++ showIrcDateTime pasteDate
+ 153 href uri ("Context in IRC" :: String)
143 154 144 155 -- | Individual paste navigation.
145 156 pasteNav :: [Language] -> [Paste] -> Paste -> Html
146 157 pasteNav langs pastes paste =
147 158 H.div ! aClass "paste-nav" $ do
… … … … Edit file src/Amelie/View/Style.hs 33188 → 33188
24 24 form
25 25 home
26 26 browse
27 27 footer
28 28 activity
+ 29 ircEntries
+ 30 + 31 -- | IRC log entries.
+ 32 ircEntries :: CSS Rule
+ 33 ircEntries = do
+ 34 classRule "irc-entries" $ do
+ 35 marginLeft "0"
+ 36 paddingLeft "0"
+ 37 listStyle "none"
29 38 30 39 -- | Footer.
31 40 footer :: CSS Rule
32 41 footer = do
33 42 classRule "footer" $ do
… … … … Edit file src/Amelie/Types/Config.hs 33188 → 33188
13 13 , configPostgres :: ConnectInfo
14 14 , configDomain :: String
15 15 , configCommits :: String
16 16 , configRepoURL :: String
17 17 , configStepevalPrelude :: FilePath
+ 18 , configIrcDir :: FilePath
18 19 } deriving (Show)
19 20 20 21 -- | Announcer configuration.
21 22 data Announcer = Announcer {
22 23 announceUser :: String
… … … … Edit file cabal-dev/cabal.config 33188 → 33188
1 1 package-db: /home/chris/Projects/me/amelie/cabal-dev/packages-6.12.3.conf
+ 2 local-repo: /home/chris/Projects/me/amelie/cabal-dev/packages
+ 3 user-install: False
2 4 remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive
3 5 remote-repo-cache: /home/chris/.cabal/packages
- 4 local-repo: /home/chris/Projects/me/amelie/cabal-dev/packages
- 5 user-install: False
+ 6 world-file: /home/chris/.cabal/world
6 7 build-summary: /home/chris/Projects/me/amelie/cabal-dev/logs/build.log
7 8 remote-build-reporting: anonymous
8 9 install-dirs user
9 10 prefix: /home/chris/Projects/me/amelie/cabal-dev/
10 11 install-dirs global
… … … … Add file src/Text/Blaze/Extra.hs 33188
+ 1 {-# LANGUAGE RecordWildCards #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + 4 + 5 module Text.Blaze.Extra where + 6 + 7 import Control.Monad + 8 import Data.Monoid + 9 import Data.Monoid.Operator + 10 import Prelude hiding ((++),head,div) + 11 import Text.Blaze.Html5 as H hiding (map) + 12 import Text.Blaze.Html5.Attributes as A + 13 import Network.URI + 14 import Text.Printf + 15 import Data.List (intercalate) + 16 + 17 elem !. className = elem ! class_ className + 18 + 19 elem !# idName = elem ! A.id idName + 20 + 21 linesToHtml :: String -> Html + 22 linesToHtml str = forM_ (lines str) $ \line -> do toHtml line; br + 23 + 24 htmlIntercalate :: Html -> [Html] -> Html + 25 htmlIntercalate _ [x] = x + 26 htmlIntercalate sep (x:xs) = do x; sep; htmlIntercalate sep xs + 27 htmlIntercalate _ [] = mempty + 28 + 29 htmlCommasAnd :: [Html] -> Html + 30 htmlCommasAnd [x] = x + 31 htmlCommasAnd [x,y] = do x; " and "; y + 32 htmlCommasAnd (x:xs) = do x; ", "; htmlCommasAnd xs + 33 htmlCommasAnd [] = mempty + 34 + 35 htmlCommas = htmlIntercalate ", " Add file src/Data/String/Extra.hs 33188
+ 1 {-# LANGUAGE TypeSynonymInstances #-} + 2 + 3 -- | Instances that can be converted to a string. + 4 + 5 module Data.String.ToString where + 6 + 7 import Data.ByteString + 8 import qualified Data.ByteString.UTF8 as UTF8 (toString) + 9 + 10 class ToString string where + 11 toString :: string -> String + 12 + 13 instance ToString String where toString = id + 14 + 15 (+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String + 16 str1 +++ str2 = toString str1 ++ toString str2 + 17 + 18 instance ToString ByteString where toString = UTF8.toString Add file src/Data/String/ToString.hs 33188
+ 1 {-# LANGUAGE TypeSynonymInstances #-} + 2 + 3 -- | Instances that can be converted to a string. + 4 + 5 module Data.String.ToString where + 6 + 7 import Data.ByteString + 8 import qualified Data.ByteString.UTF8 as UTF8 (toString) + 9 + 10 class ToString string where + 11 toString :: string -> String + 12 + 13 instance ToString String where toString = id + 14 + 15 (+++) :: (ToString str1,ToString str2) => str1 -> str2 -> String + 16 str1 +++ str2 = toString str1 ++ toString str2 + 17 + 18 instance ToString ByteString where toString = UTF8.toString Add file src/Amelie/View/Irclogs.hs 33188
+ 1 {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 {-# LANGUAGE RecordWildCards #-} + 4 + 5 -- | Irclogs page view. + 6 + 7 module Amelie.View.Irclogs + 8 (page) + 9 where + 10 + 11 import Amelie.Types + 12 import Amelie.View.Html + 13 import Amelie.View.Layout + 14 + 15 import Control.Monad + 16 import Data.Char + 17 import Data.Maybe + 18 import Data.Monoid.Operator ((++)) + 19 import Data.String + 20 import Data.Text (Text) + 21 import qualified Data.Text as T + 22 import Prelude hiding ((++)) + 23 import Text.Blaze.Extra + 24 import Text.Blaze.Html5 as H hiding (map) + 25 import qualified Text.Blaze.Html5.Attributes as A + 26 + 27 -- | Render the irclogs page. + 28 page :: String -> String -> String -> Either String [Text] -> Html + 29 page channel date time entries = + 30 layoutPage $ Page { + 31 pageTitle = "Development irclogs" + 32 , pageBody = irclogs channel entries + 33 , pageName = "irclogs" + 34 } + 35 + 36 -- | View the paginated pastes. + 37 irclogs :: String -> Either String [Text] -> Html + 38 irclogs channel entries = do + 39 darkSection "IRC logs" $ do + 40 p $ do "Channel: #"; toHtml channel + 41 lightSection (fromString ("#" ++ channel)) $ do + 42 case entries of + 43 Left error -> do "Unable to get logs for this channel and date: " + 44 toHtml error + 45 Right entries -> + 46 ul !. "amelie-irc-entries" $ + 47 forM_ entries $ \entry -> do + 48 let date = toValue $ parseDate entry + 49 li $ do + 50 a ! A.name date ! A.id date $ return () + 51 toHtml entry + 52 + 53 where parseDate = T.replace ":" "-" . T.takeWhile (not.isSpace) Add file src/Amelie/Model/Irclogs.hs 33188
+ 1 {-# LANGUAGE ViewPatterns #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 module Amelie.Model.Irclogs where + 4 + 5 import Amelie.Types + 6 + 7 import Control.Applicative + 8 import Control.Arrow + 9 import Control.Monad.IO + 10 import Control.Monad.Reader + 11 import Data.ByteString (ByteString) + 12 import qualified Data.ByteString as S + 13 import Data.Char + 14 import Data.Either + 15 import Data.List (find) + 16 import Data.List.Utils + 17 import Data.Maybe + 18 import Data.Monoid.Operator ((++)) + 19 import Data.Text (Text) + 20 import qualified Data.Text as T + 21 import Data.Text.Encoding + 22 import Data.Time + 23 import Data.Time.Calendar + 24 import Network.Curl.Download + 25 import Prelude hiding ((++)) + 26 import System.Directory + 27 import System.FilePath + 28 import System.Locale + 29 + 30 -- | Get IRC logs for the given channel narrowed down to the given date/time. + 31 getNarrowedLogs :: String -- ^ Channel name. + 32 -> String -- ^ Date. + 33 -> String -- ^ Time. + 34 -> Controller (Either String [Text]) + 35 getNarrowedLogs channel year time = do + 36 case parseIrcDate year of + 37 Nothing -> return $ Left $ "Unable to parse year: " ++ year + 38 Just date -> do + 39 days <- mapM (getLogs channel . showIrcDate) [addDays (-1) date,date,addDays 1 date] + 40 let events = concat (rights days) + 41 return (Right (fromMaybe events + 42 (narrowBy (T.isPrefixOf datetime) events <|> + 43 narrowBy (T.isPrefixOf dateminute) events <|> + 44 narrowBy (T.isPrefixOf datehour) events <|> + 45 narrowBy (T.isPrefixOf datestr) events <|> + 46 narrowBy (T.isPrefixOf dateday) events))) + 47 + 48 where narrowBy pred events = + 49 case find pred (filter crap events) of + 50 Nothing -> Nothing + 51 Just res -> Just $ narrow count pred (filter crap events) + 52 count = 50 + 53 datetime = T.pack $ year ++ "-" ++ replace "-" ":" time + 54 dateminute = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 2 . reverse $ time) + 55 datehour = T.pack $ year ++ "-" ++ replace "-" ":" (reverse . drop 5 . reverse $ time) + 56 datestr = T.pack $ year ++ "-" + 57 dateday = T.pack $ reverse . drop 2 . reverse $ year + 58 crap = not . T.isPrefixOf " --- " . T.dropWhile (not . isSpace) + 59 + 60 -- | Narrow to surrounding predicate. + 61 narrow :: Int -> (a -> Bool) -> [a] -> [a] + 62 narrow n f = uncurry (++) . (reverse . take n . reverse *** take n) . break f + 63 + 64 -- | Get IRC logs for the given channel and date. + 65 getLogs :: String -- ^ Channel name. + 66 -> String -- ^ Date. + 67 -> Controller (Either String [Text]) + 68 getLogs channel year = do + 69 dir <- asks $ configIrcDir . controllerStateConfig + 70 io $ do + 71 now <- fmap (showIrcDate . utctDay) getCurrentTime + 72 result <- openURICached (year /= now) (file dir) uri + 73 case result of + 74 Left err -> return $ Left $ uri ++ ": " ++ err + 75 Right bytes -> return $ Right (map addYear (T.lines (decodeASCII bytes))) + 76 + 77 where uri = "http://tunes.org/~nef/logs/" ++ channel ++ "/" ++ yearStr + 78 file dir = dir </> channel ++ "-" ++ yearStr + 79 yearStr = replace "-" "." (drop 2 year) + 80 addYear line = T.pack year ++ "-" ++ line + 81 + 82 -- | Open the URI and cache the result. + 83 openURICached :: Bool -> FilePath -> String -> IO (Either String ByteString) + 84 openURICached noCache path url = do + 85 exists <- doesFileExist path + 86 if exists && not noCache + 87 then fmap Right $ S.readFile path + 88 else do result <- openURI url + 89 case result of + 90 Right bytes -> S.writeFile path bytes + 91 _ -> return () + 92 return result + 93 + 94 -- | Parse an IRC date string into a date. + 95 parseIrcDate :: String -> Maybe Day + 96 parseIrcDate = parseTime defaultTimeLocale "%Y-%m-%d" + 97 + 98 -- | Show a date to an IRC date format. + 99 showIrcDate :: Day -> String + 100 showIrcDate = formatTime defaultTimeLocale "%Y-%m-%d" + 101 + 102 -- | Show a date to an IRC date format. + 103 showIrcDateTime :: UTCTime -> String + 104 showIrcDateTime = + 105 formatTime defaultTimeLocale "%Y-%m-%d/%H/%M/%S" . addUTCTime ((-8)*60*60) Add file src/Amelie/Controller/Irclogs.hs 33188
+ 1 {-# OPTIONS -Wall #-} + 2 {-# LANGUAGE OverloadedStrings #-} + 3 + 4 -- | Irclogs page controller. + 5 + 6 module Amelie.Controller.Irclogs + 7 (handle) + 8 where + 9 + 10 import Amelie.Controller + 11 import Amelie.Model.Irclogs + 12 import Amelie.Types + 13 import Amelie.View.Irclogs (page) + 14 + 15 import Data.String.ToString + 16 import Data.String + 17 import Snap.Types + 18 + 19 handle :: Controller () + 20 handle = do + 21 channel <- get "channel" + 22 date <- get "date" + 23 time <- get "timestamp" + 24 logs <- getNarrowedLogs channel date time + 25 output $ page channel date time logs + 26 + 27 where get key = do + 28 value <- fmap (fmap toString) $ getParam (fromString key) + 29 case value of + 30 Nothing -> error $ "Missing parameter: " ++ key + 31 Just value -> return value