diff --git a/Extemp.hs b/Extemp.hs new file mode 100644 --- /dev/null +++ b/Extemp.hs @@ -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 "]+HREF=\"([^\"]*)\"[^>]*> *view full text[^<]*") 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 "]+HREF=\"([^\"]*)\"[^>]*> *print *") 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 "
" $ + L.append "
" $ flip L.append "
" $ 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 "]*media=\"screen\"[^>]*>") x of + (b,_:: L.ByteString,e) -> L.append b e + noScript x = if L.null x then x else case match (iPat "]*javascript.*(|/>)") 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/extemp.cabal b/extemp.cabal new file mode 100644 --- /dev/null +++ b/extemp.cabal @@ -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: +