extemp (empty) → 0.0.1
raw patch · 4 files changed
+375/−0 lines, 4 filesdep +HTTPdep +MaybeTdep +basesetup-changed
Dependencies added: HTTP, MaybeT, base, bytestring, containers, feed, happstack-auth, happstack-server, happstack-state, happstack-util, monad-parallel, mtl, network, old-locale, regex-tdfa, smartGroup, stringsearch, time, xhtml, xml
Files
- Extemp.hs +282/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- extemp.cabal +61/−0
+ Extemp.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables,+ TypeFamilies, MultiParamTypeClasses, FlexibleContexts, StandaloneDeriving,+ TypeSynonymInstances, TypeOperators #-}+module Main where+import SmartGroup+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.Search as S+import Data.Maybe+import Data.Monoid+import Data.Typeable+import Data.Time+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Maybe+import Control.Concurrent+import Happstack.Server.SimpleHTTP as HS+import Happstack.State+import Happstack.Util.Cron+import Happstack.Auth+import System.Environment+import System.Locale+import Text.XHtml hiding (dir)+import Text.Feed.Query+import Text.Feed.Import+import Text.Feed.Types+import Text.XML.Light+import Text.Regex.TDFA+import Text.Regex.TDFA.Common hiding (look)+import Network.URI (URI(..),URIAuth(..), relativeTo, parseURI, parseURIReference, uriQuery)+import qualified Network.HTTP.Base as HTTP+import Network.HTTP.Headers+import Network.Browser hiding (Proxy)+import qualified Control.Monad.Parallel as P++deriving instance Read URIAuth+deriving instance Ord URIAuth+deriving instance Read URI+deriving instance Ord URI+instance Version URIAuth+instance Version URI+$(deriveSerialize ''URIAuth)+$(deriveSerialize ''URI)+data FeedError = InvalidFeed URI | NoConnect URI deriving (Show,Read,Ord,Eq,Typeable)+$(deriveSerialize ''FeedError)+instance Version FeedError+data Config = Config (Map String URI) (Set String) [L.ByteString] Day (Set FeedError) deriving (Read,Show,Ord,Eq,Typeable)+instance Version Config+$(deriveSerialize ''Config)+instance Component Config where+ type Dependencies Config = AuthState :+: End+ initialValue = Config Map.empty Set.empty [] (ModifiedJulianDay 0) Set.empty++addSource :: String -> Update Config String+addSource i = case parseURI i of+ (Just u) -> (modify $ \(Config us ss o d errs)-> Config (Map.insert i u us) ss o d errs) >> return "/"+ Nothing -> return "invalid"++delSource :: String -> Update Config ()+delSource i = modify $ \(Config us ss o d errs)-> Config (Map.delete i us) ss o d errs++addErr :: FeedError -> Update Config ()+addErr i = modify $ \(Config us ss o d errs)-> Config us ss o d (Set.insert i errs)++delErr :: FeedError -> Update Config ()+delErr i = modify $ \(Config us ss o d errs)-> Config us ss o d (Set.delete i errs)++getConfig :: Query Config Config+getConfig = askState++putConfig :: Config -> Update Config ()+putConfig = putState++$(mkMethods ''Config ['addSource, 'delSource, 'addErr, 'delErr, 'getConfig, 'putConfig])++showErr :: FeedError -> String+showErr (InvalidFeed u) = (show u) ++ " is not a valid feed."+showErr (NoConnect u) = "Could not connect to " ++ (show u)++liftMaybe :: Maybe a -> MaybeT IO a+liftMaybe = MaybeT . return++printIt :: ServerPartT IO Response+printIt = do+ (Config us ss o _ errs) <- query GetConfig+ d <- liftIO $ liftM utctDay $ getCurrentTime+ update $ PutConfig $ Config us ss [] d errs+ let a = L.concat o+ return $ if L.null a+ then toResponse $ centerHtml 500 << paragraph << ("No new articles" :: String)+ else toResponseBS "text/html; charset=UTF-8" a++refreshCache :: IO ()+refreshCache = do+ putStrLn "Refreshing cache"+ (Config us ss _ _ _) <- query GetConfig+ as <- newItems ss (Map.elems us)+ d <- liftIO $ liftM utctDay $ getCurrentTime+ o' <- getArticles as+ (Config _ _ _ _ errs) <- query GetConfig+ update $ PutConfig $ Config us (Set.union (Set.fromList $ mapMaybe getItemTitle as) ss) o' d errs+ putStrLn "Done refreshing"++getArticles :: [Item] -> IO [L.ByteString]+getArticles = liftM (concat . groupLog 2 stripHtml . catMaybes) . P.mapM (\x->+ runMaybeT $ (liftMaybe (getItemLink x >>= parseURI) >>= download >>= (return . prepPage)))++getURI :: Maybe URI -> URI -> MaybeT IO (URI, L.ByteString)+getURI f u = handleErr (NoConnect u) $ MaybeT $ browse $ do+ setOutHandler (const $ return ()) >> setErrHandler (const $ return ())+ setAllowRedirects True+ let fn = case f of+ (Just fu) -> insertHeader HdrReferer (show fu)+ Nothing -> id+ (e,r) <- (request (fn (HTTP.mkRequest HTTP.GET u)))+ case HTTP.rspCode r of+ (2,_,_) -> return (Just (e,(HTTP.rspBody r)))+ otherwise -> return Nothing++handleErr :: FeedError -> MaybeT IO a -> MaybeT IO a+handleErr e a = MaybeT $ do+ i <- runMaybeT a+ case i of+ (Just x) -> update (DelErr e) >> return i+ Nothing -> update (AddErr e) >> return Nothing++mkRel :: URI -> L.ByteString -> Maybe URI+mkRel u b = do+ x <- parseURIReference (L.unpack b)+ r <- x `relativeTo` u+ return (r{uriQuery = uriQuery x})++download :: URI -> MaybeT IO (URI, L.ByteString)+download s = do+ (s',a) <- getURI Nothing s+ let (_::L.ByteString,_::L.ByteString,_::L.ByteString,x) = match (iPat "<A[^>]+HREF=\"([^\"]*)\"[^>]*> *view full text[^<]*</a>") a+ (s'',a') <- case x of+ (h:_) -> maybe (return (s',a)) (getURI (Just s)) (mkRel s' h)+ [] -> return (s',a)+ let (_::L.ByteString,_::L.ByteString,_::L.ByteString,y) = match (iPat "<A[^>]+HREF=\"([^\"]*)\"[^>]*> *print *</a>") a'+ case y of+ (h:_) -> maybe (return (s'',a')) (getURI (Just s')) (mkRel s'' h)+ [] -> return (s'',a')++iPat :: L.ByteString -> Regex+iPat = makeRegexOpts (defaultCompOpt {caseSensitive = False}) blankExecOpt++readFeed :: Element -> MaybeT IO Feed+readFeed x = liftMaybe $ readAtom x `mplus` readRSS2 x `mplus` readRSS1 x `mplus` Just (XMLFeed x)++newItems :: Set String -> [URI] -> IO [Item]+newItems is us = liftM concat $ flip P.mapM us $ \u-> do+ f <- runMaybeT $ liftM snd (getURI Nothing u) >>= (\x-> handleErr (InvalidFeed u) $ (liftMaybe $ parseXMLDoc x) >>= readFeed)+ return $ case f of+ (Just a) -> filter (\x-> maybe False (not. flip Set.member is) (getItemTitle x)) (getFeedItems a)+ Nothing -> []++mainPage :: ServerPartT IO Response+mainPage = do+ (Config us _ _ d errs) <- query GetConfig+ let options = map (option <<) (Map.keys us)+ return . toResponse . toHtml $ [+ header << thetitle << ("Extemp Printing" :: String),+ body << centerHtml 210 << [+ smallErr (map ((+++ br) . showErr) (Set.toList errs)),+ thediv << [paragraph << ("Last Printed: " ++ formatTime defaultTimeLocale "%D" d),+ gui "print" << submit "" "Print"],+ thediv ! [thestyle "padding-top: 25px;"] <<+ table ! [thestyle "background-color:#b0c4de;"] <<+ ((td << gui "del" << (select ! [name "delItem", thestyle "width: 150px;"]+ << options +++ submit "" "Delete"))+ </> (td << gui "add" << [textfield "addItem", submit "" "Add"]))]]++centerHtml :: Int -> Html -> Html+centerHtml n = thediv ! [thestyle $ "margin: 0px auto; width: " ++ (show n) ++ "px; padding-top: 100px;"]++errHtml :: Html -> Html+errHtml = thediv ! [thestyle "color: red;"]++smallErr :: HTML a => a -> Html+smallErr a = errHtml << paragraph ! [thestyle "font-size: small;"] << a+++prepPage :: (URI, L.ByteString) -> L.ByteString+prepPage (h,a) = flip L.append "<DIV style=\"page-break-after:always;\"/>" $+ L.append "<DIV style=\"color: white; font: normal;\">" $ flip L.append "</DIV>" $ noPrint $ nonRelative $ noScreen $ noScript a where+ noPrint = S.replace "media=\"print\"" L.empty+ nonRelative s = if L.null s then s else case match (iPat "href=\"([^\" ]*) *\"") s of+ (b,m,e,l:_) -> case mkRel h l of+ (Just rel) -> b `L.append` "href=\"" `L.append` L.pack (show rel) `L.append` "\"" `L.append` (nonRelative e)+ Nothing -> b `L.append` m `L.append` (nonRelative e)+ (b,_::L.ByteString,_::L.ByteString,_::[L.ByteString]) -> b+ noScreen x = case match (iPat "<link[^>]*media=\"screen\"[^>]*>") x of+ (b,_:: L.ByteString,e) -> L.append b e+ noScript x = if L.null x then x else case match (iPat "<script[^>]*javascript.*(</script>|/>)") x of+ (b,_:: L.ByteString,e) -> L.append b (noScript e)++stripHtml :: L.ByteString -> L.ByteString+stripHtml s = if L.null s then s else case s =~ ("<.*>":: L.ByteString) of+ (b,_::L.ByteString,e) -> L.append b (stripHtml e)++controller :: ServerPartT IO Response+controller = updateTimeout 5 >> msum [+ dir "login" $ mplus+ (methodSP HS.GET loginPage)+ (methodSP HS.POST (loginHandler 5 Nothing Nothing (redir "/") (const (const badLogin)))),+ dir "register" $ mplus+ (methodSP HS.GET registerPage)+ (methodSP HS.POST $ withDataFn getRegisterInfo (\x->uncurry (register 5) x (redir "/") (redir "/")) `mplus` noMatch),+ loginGate (msum [+ dir "print" printIt,+ dir "add" (withDataFn (look "addItem") (update . AddSource) >>= redir),+ dir "del" (withDataFn (look "delItem") (update . DelSource) >> redir "/"),+ dir "invalid" (return $ toResponse $ errHtml << centerHtml 500 << paragraph << ("Invalid Feed URI" :: String)),+ nullDir >> mainPage]) (redir "login")]++redir :: String -> ServerPartT IO Response+redir s = seeOther s (toResponse ("" :: String))++getRegisterInfo :: RqData (Username, Password)+getRegisterInfo = do+ username <- look "username"+ password <- look "password"+ passcheck <- look "passcheck"+ guard (password == passcheck) >> return (username, password)++loginWith :: Html -> ServerPartT IO Response +loginWith h = return $ toResponse $ centerHtml 201 << table << gui "login" << (h </>+ (td << [bold << ("Username:"::String), textfield "username"])+ </> (td << [bold << ("Password:"::String), password "password"])+ </> (td << submit "" "Login")+ </> (td << hotlink "register" (paragraph ! [align "right"] << ("register"::String))))++badLogin :: ServerPartT IO Response+badLogin = loginWith (smallErr ("Invalid username or password" :: String))++loginPage :: ServerPartT IO Response+loginPage = loginWith mempty++noMatch :: ServerPartT IO Response+noMatch = registerWith (smallErr ("Your passwords don't match. Try again."::String))++registerPage :: ServerPartT IO Response+registerPage = registerWith mempty++registerWith :: Html -> ServerPartT IO Response+registerWith h = return $ toResponse $ centerHtml 201 << gui "register" << table << (h </>+ (td << [bold << ("Username:"::String), textfield "username"])+ </> (td << [bold << ("Password:"::String), password "password"])+ </> (td << [bold << ("Confirm Password:"::String), password "passcheck"])+ </> (td << submit "" "Login"))++main :: IO ()+main = do+ putStrLn "Extemp Printing, version 0.0.1"+ putStrLn "Copyright (C) 2010 Sam Anklesaria under BSD"+ args <- getArgs+ control <- startSystemState (Proxy :: Proxy Config)+ tid <- forkIO $ simpleHTTP nullConf{port= case args of {x:[] -> read x; _ -> 8000}} controller+ c <- forkIO $ cron 86400 (createCheckpoint control)+ d <- forkIO $ cron 300 refreshCache+ interpreter+ putStrLn "Shutting down..."+ killThread tid+ killThread c+ killThread d+ createCheckpoint control+ shutdownSystem control+ putStrLn "Shutdown complete"++interpreter :: IO ()+interpreter = do + l <- getLine+ case l of+ "quit" -> return ()+ "refresh" -> refreshCache >> interpreter+ "state" -> query GetConfig >>= print >> interpreter+ otherwise -> interpreter
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Sam Anklesaria++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sam Anklesaria nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ extemp.cabal view
@@ -0,0 +1,61 @@+-- extemp.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: extemp++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.0.1++-- A short (one-line) description of the package.+Synopsis: automated printing for extemp speakers++-- A longer description of the package.+Description: Extemp speakers conventionally must repetitively print from the same news services week after week, afterwords sorting the results by news area in a time consuming, labor intensive process. This package builds a web app automates the process. ++-- URL for the project homepage or repository.+Homepage: http://patch-tag.com/r/salazar/extemp++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Sam Anklesaria++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: amsay@amsay.net++-- A copyright notice.+-- Copyright: © 2010 Sam Anklesaria++Category: Web++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Executable extemp+ -- .hs or .lhs file containing the Main module.+ Main-is: Extemp.hs+ + -- Packages needed in order to build this package.+ Build-depends: base >= 3 && < 5, base, smartGroup >= 0.2 && < 1, bytestring < 1, MaybeT, HTTP > 4000 && < 5000, containers < 1, stringsearch < 1, happstack-server, happstack-state, happstack-util, xhtml, feed, time, old-locale, network, regex-tdfa, xml, mtl, monad-parallel, happstack-auth+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +