extemp-0.0.1: Extemp.hs

{-# 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