for a single blog post -postHTML :: Page -> XMLGenT (Clck ClckURL) XML -postHTML Page{..} = -

<% pageTitle %>

- Posted on <% pageDate %> by <% authorName %> - <% pageSrc %> -

- where - authorName :: Clck ClckURL Text - authorName = - do mu <- getUsername pageAuthor - return $ fromMaybe (pack "Anonymous") mu - -page :: XMLGenT (Clck ClckURL) XML -page = - do ttl <- lift getBlogTitle - template (unpack ttl) () $ - <%> -

<% ttl %>

- <% postsHTML %> -

- rmfile ./clckwrks-theme-happstack/Theme/Blog.hs hunk ./clckwrks-theme-happstack/Theme/Home.hs 1 -{-# OPTIONS_GHC -F -pgmFtrhsx #-} - -module Theme.Home where - -import Clckwrks -import Theme.Template - -summaryBox :: PageId -> String -> String -> GenXML (Clck ClckURL) -summaryBox pid title iconURL = -

<% title %>

- <% getPageSummary pid %> -

Elegance

Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec ut tortor non augue tincidunt iaculis. Cras ac diam rhoncus nibh commodo iaculis vel sed ligula. Curabitur fringilla tortor sed massa consequat convallis. Maecenas consectetur tincidunt porttitor. Aenean quis posuere augue.

- -

Speed

- -

Power

- - - - - rmfile ./clckwrks-theme-happstack/Theme/HomeOld.hs hunk ./clckwrks-theme-happstack/Theme/Page.hs 1 -{-# OPTIONS_GHC -F -pgmFtrhsx #-} -module Theme.Page where hunk ./clckwrks-theme-happstack/Theme/Page.hs 2 -import Clckwrks -import Data.Text (unpack) -import Theme.Template - -page :: XMLGenT (Clck ClckURL) XML -page = - do ttl <- lift getPageTitle - template (unpack ttl) () $ - <%> -

<% getPageTitle %>

- <% getPageContent %> -

- -{- - - - <% getPageTitle %> - - - - - - <% getMenu %> - -

- - - -

- The relentless, uncompromised power and beauty of Haskell for the web -

Elegance

- -

Speed

- -

Power

- - - - - - -{- - - - <% getPageTitle %> - - - - - - -

<% getPageTitle %>

<% getPageContent %>

- - --} --} rmfile ./clckwrks-theme-happstack/Theme/Page.hs hunk ./clckwrks-theme-happstack/Theme/Template.hs 1 -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -F -pgmFtrhsx #-} -module Theme.Template where - -import Clckwrks -import Clckwrks.ProfileData.Acid (HasRole(..)) -import qualified Data.Set as Set -import Data.String (IsString(..)) -import Data.Text (Text) -import HSP.Google.Analytics (UACCT(..), analyticsAsync) - -template :: - ( EmbedAsChild (Clck ClckURL) headers - , EmbedAsChild (Clck ClckURL) body - ) => - String - -> headers - -> body - -> XMLGenT (Clck ClckURL) XML -template title headers body = - - - <% title %> - - - <% headers %> - <% googleAnalytics %> - - - - <% body %> - -

- <% do mu <- getUserId - case mu of - Nothing -> <% () %> - (Just uid) -> - do r <- query (HasRole uid (Set.singleton Administrator)) - if not r - then <% () %> - else do pid <- lift getPageId - <%> -

admin console

edit this page

- - %> -

- - rmfile ./clckwrks-theme-happstack/Theme/Template.hs rmdir ./clckwrks-theme-happstack/Theme hunk ./clckwrks-theme-happstack/Theme.hs 1 +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Theme where + +import Clckwrks +import Clckwrks.Monad +import Clckwrks.ProfileData.Acid (HasRole(..)) +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import Data.Text (Text, unpack) +-- import Happstack.Server +import HSP +import Paths_clckwrks_theme_happstack (getDataDir) + +theme :: Theme +theme = Theme + { themeName = "happstack" + , _themeTemplate = pageTemplate + , themeBlog = blog + , themeDataDir = getDataDir + } + +pageTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers + , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body + ) => + Text + -> headers + -> body + -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML +pageTemplate ttl hdr bdy = + do pid <- XMLGenT $ getPageId + case pid of + (PageId 1) -> home ttl hdr bdy + _ -> standardTemplate ttl hdr

Documentation

+ <% bdy %> +

+ +------------------------------------------------------------------------------ +-- standard template +------------------------------------------------------------------------------ + +standardTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers + , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body + ) => + Text + -> headers + -> body + -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML +standardTemplate ttl hdrs bdy = + + + <% ttl %> + + + <% hdrs %> + <% googleAnalytics %> + + + + + <% bdy %> + +

+ <% do mu <- getUserId + case mu of + Nothing -> <% () %> + (Just uid) -> + do r <- query (HasRole uid (Set.singleton Administrator)) + if not r + then <% () %> + else do pid <- lift getPageId + <%> +

admin console

edit this page

+ + %> +

+ + + +------------------------------------------------------------------------------ +-- Home +------------------------------------------------------------------------------ + +summaryBox :: PageId -> String -> String -> GenXML (Clck ClckURL) +summaryBox pid title iconURL = +

<% title %>

+ <% getPageSummary pid %> +

<% pageTitle %>

+ Posted on <% pageDate %> by <% authorName %> + <% pageSrc %> +

permalink

+ where + authorName :: Clck ClckURL Text + authorName = + do mu <- getUsername pageAuthor + return $ fromMaybe "Anonymous" mu + +blog :: XMLGenT (Clck ClckURL) XML +blog = + do ttl <- lift getBlogTitle + standardTemplate ttl () $ + <%> +

<% ttl %>

+ <% postsHTML %> +

+ hunk ./clckwrks-theme-happstack/clckwrks-theme-happstack.cabal 2 -Version: 0.1.22 +Version: 0.2.0 hunk ./clckwrks-theme-happstack/clckwrks-theme-happstack.cabal 9 -Maintainer: jeremy@n-heptane.com +Maintainer: Jeremy Shaw hunk ./clckwrks-theme-happstack/clckwrks-theme-happstack.cabal 24 - Exposed-modules: Theme.Blog, - Theme.Home, - Theme.Page, - Theme.Template + Exposed-modules: Theme hunk ./clckwrks-theme-happstack/clckwrks-theme-happstack.cabal 29 - clckwrks == 0.12.*, + clckwrks == 0.13.*, hunk ./clckwrks-theme-happstack/clckwrks-theme-happstack.cabal 31 - happstack-hsp == 7.1.*, + hsp == 0.7.*, hunk ./happstack-dot-com/Main.hs 1 -{-# LANGUAGE CPP, RankNTypes, RecordWildCards, OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes #-} hunk ./happstack-dot-com/Main.hs 4 -import Control.Concurrent (forkIO, killThread) -import Control.Monad.State (evalStateT, get, modify) -import Clckwrks -import Clckwrks.Admin.Template (defaultAdminMenu) -import Clckwrks.IrcBot (IrcConfig(..), IrcBotConfig(..), User(..), IrcBotURL(..), addIrcBotAdminMenu, withIrcBotConfig, runIrcBotT, routeIrcBot) +import Clckwrks.URL +import Clckwrks.Admin.Template +import Clckwrks.GetOpts +import Clckwrks.Monad hunk ./happstack-dot-com/Main.hs 9 -import Clckwrks.Media -import Clckwrks.Media.PreProcess (mediaCmd) -import qualified Data.ByteString.Char8 as C -import Data.List (intercalate) -import qualified Data.Map as Map -import Data.Monoid (mappend) -import qualified Data.Set as Set -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text as Text -import Happstack.Server.SimpleHTTP (waitForTermination) -import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI) -import qualified Paths_clckwrks as Clckwrks -#ifdef CABAL -import qualified Paths_clckwrks_theme_happstack as Theme -#endif -import qualified Paths_clckwrks_plugin_media as Media -import System.Console.GetOpt -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.FilePath (()) -import Theme.Template (template) -import URL -import Web.Routes.Happstack () -import qualified Theme.Blog as Blog -#ifdef PLUGINS -import Control.Monad.State (get) -import System.Plugins.Auto (PluginHandle, PluginConf(..), defaultPluginConf, initPlugins, withMonadIOFile) -#else -import PageMapper -#endif +import Clckwrks.Plugin +import Clckwrks.IrcBot.Plugin +import Clckwrks.Media.Plugin +import Control.Applicative ((<$>)) +import Control.Monad.Trans +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Happstack.Server +import Theme +import Web.Plugins.Core (initPlugin, setTheme) +import System.Environment (getArgs) hunk ./happstack-dot-com/Main.hs 22 ------------------------------------------------------------------------------- --- Command line options ------------------------------------------------------------------------------- - --- | command-line Flags -data Flag - = ModifyConfig (forall url. ClckwrksConfig url -> ClckwrksConfig url) - | Help - | Version - --- | Flag selectors -isHelp, isVersion :: Flag -> Bool -isHelp flag = case flag of Help -> True; _ -> False -isVersion flag = case flag of Version -> True; _ -> False - --- | Command line options. -clckwrksOpts :: ClckwrksConfig SiteURL -> [OptDescr Flag] -clckwrksOpts def = - [ -- Option [] ["version"] (NoArg Version) "Display version information" - Option [] ["help"] (NoArg Help) "Display this help message" - , Option [] ["http-port"] (ReqArg setPort "port") ("Port to bind http server, default: " ++ show (clckPort def)) - , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostename, default: " ++ show (clckHostname def)) - , Option [] ["base-uri"] (ReqArg setBaseURI "URI") ("Hostname and port, default: " ++ show ("http://" ++ clckHostname def ++ ":" ++ show (clckPort def))) - , Option [] ["jquery-path"] (ReqArg setJQueryPath "path") ("path to jquery directory, default: " ++ show (clckJQueryPath def)) - , Option [] ["jqueryui-path"] (ReqArg setJQueryUIPath "path") ("path to jqueryui directory, default: " ++ show (clckJQueryUIPath def)) - , Option [] ["jstree-path"] (ReqArg setJSTreePath "path") ("path to jstree directory, default: " ++ show (clckJSTreePath def)) - , Option [] ["json2-path"] (ReqArg setJSON2Path "path") ("path to json2 directory, default: " ++ show (clckJSON2Path def)) - , Option [] ["theme-path"] (ReqArg setThemeDir "path") ("path to theme directory, default: " ++ show (clckThemeDir def)) - , Option [] ["top"] (ReqArg setTopDir "path") ("path to directory that holds the state directory, uploads, etc") - , Option [] ["static"] (ReqArg noop "ignored") "unused" - , Option [] ["logs"] (ReqArg noop "ignored") "unimplemented" - , Option [] ["log-mode"] (ReqArg noop "ignored") "unimplemented" - , Option [] ["enable-analytics"] (NoArg setAnalytics) "enable google analytics tracking" - ] - where - noop _ = ModifyConfig $ id - setPort str = ModifyConfig $ \c -> c { clckPort = read str } - setHostname str = ModifyConfig $ \c -> c { clckHostname = str } - setBaseURI str = let Just (URI {uriAuthority = Just (URIAuth {uriRegName = host, uriPort = port})}) = parseAbsoluteURI str in - ModifyConfig $ \c -> c { clckHostname = host, clckPort = read port } - setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str } - setJQueryUIPath str = ModifyConfig $ \c -> c { clckJQueryUIPath = str } - setJSTreePath str = ModifyConfig $ \c -> c { clckJSTreePath = str } - setJSON2Path str = ModifyConfig $ \c -> c { clckJSON2Path = str } - setThemeDir str = ModifyConfig $ \c -> c { clckThemeDir = str } - setTopDir str = ModifyConfig $ \c -> c { clckTopDir = Just str } - setAnalytics = ModifyConfig $ \c -> c { clckEnableAnalytics = True } - --- | Parse the command line arguments into a list of flags. Exits with usage --- message, in case of failure. -parseArgs :: [OptDescr Flag] -> [String] -> IO (ClckwrksConfig url -> ClckwrksConfig url) -parseArgs opts args = - case getOpt Permute opts args of - (flags,_,[]) -> - if any isHelp flags - then do putStr (helpMessage opts) - exitSuccess - else do return $ foldr (.) id [f | (ModifyConfig f) <- flags ] - (_,_,errs) -> - do putStr ("Failure while parsing command line:\n"++unlines errs) - putStr (helpMessage opts) - exitFailure - --- | A simple usage message listing all flags possible. -helpMessage :: [OptDescr Flag] -> String -helpMessage opts = - usageInfo header opts - where - header = "Usage: clckwrks [OPTION...]" - -clckwrksConfig :: IO (ClckwrksConfig SiteURL) -clckwrksConfig = - do clckDir <- Clckwrks.getDataDir -#ifdef CABAL - themeDir <- Theme.getDataDir -#else - let themeDir = "../clckwrks-theme-happstack/" -#endif - mediaDir <- Media.getDataDir - return $ ClckwrksConfig - { clckHostname = "localhost" - , clckPort = 8000 - , clckURL = C - , clckJQueryPath = "/usr/share/javascript/jquery/" - , clckJQueryUIPath = "/usr/share/javascript/jquery-ui/" - , clckJSTreePath = clckDir "jstree" - , clckJSON2Path = clckDir "json2" - , clckThemeDir = themeDir - , clckPluginDir = Map.fromList [("media", mediaDir)] - , clckStaticDir = clckDir "static" - , clckTopDir = Nothing -#ifdef PLUGINS - , clckPageHandler = undefined -#else - , clckPageHandler = staticPageHandler -#endif - , clckBlogHandler = staticBlogHandler - , clckEnableAnalytics = False - } - -getClckwrksConfig :: [OptDescr Flag] - -> ClckwrksConfig SiteURL - -> IO (ClckwrksConfig SiteURL) -getClckwrksConfig opts cc = - do args <- getArgs - f <- parseArgs opts args - return (f cc) hunk ./happstack-dot-com/Main.hs 24 --- SitePlus +-- ClckwrksConfig hunk ./happstack-dot-com/Main.hs 27 -data SitePlus url a = SitePlus - { siteSite :: Site url a - , siteDomain :: Text - , sitePort :: Int - , siteAppRoot :: Text - , sitePrefix :: Text - , siteShowURL :: url -> [(Text, Maybe Text)] -> Text - , siteParsePathInfo :: C.ByteString -> Either String url +clckwrksConfig :: ClckwrksConfig +clckwrksConfig = ClckwrksConfig + { clckHostname = "localhost" + , clckPort = 8000 + , clckHidePort = False + , clckJQueryPath = "" + , clckJQueryUIPath = "" + , clckJSTreePath = "" + , clckJSON2Path = "" + , clckTopDir = Nothing + , clckEnableAnalytics = False + , clckInitHook = initHook hunk ./happstack-dot-com/Main.hs 41 -instance Functor (SitePlus url) where - fmap f sitePlus = sitePlus { siteSite = fmap f (siteSite sitePlus) } - -mkSitePlus :: Text - -> Int - -> Text - -> Site url a - -> SitePlus url a -mkSitePlus domain port approot site = - SitePlus { siteSite = site - , siteDomain = domain - , sitePort = port - , siteAppRoot = approot - , sitePrefix = prefix - , siteShowURL = showFn - , siteParsePathInfo = parsePathSegments site . decodePathInfo - } - where - showFn url qs = - let (pieces, qs') = formatPathSegments site url - in prefix `mappend` (encodePathInfo pieces (qs ++ qs')) - prefix = Text.concat $ [ Text.pack "http://" - , domain - ] ++ - (if port == 80 || port == 9028 - then [] - else [Text.pack ":", Text.pack $ show port] - ) ++ - [ approot ] - -runSitePlus_ :: (Happstack m) => SitePlus url (m a) -> m (Either String a) -runSitePlus_ sitePlus = - dirs (Text.unpack (siteAppRoot sitePlus)) $ - do rq <- askRq - let r = runSite (sitePrefix sitePlus) (siteSite sitePlus) (map Text.pack $ rqPaths rq) - case r of - (Left parseError) -> return (Left parseError) - (Right sp) -> Right <$> (localRq (const $ rq { rqPaths = [] }) sp) - where - escapeSlash :: String -> String - escapeSlash [] = [] - escapeSlash ('/':cs) = "%2F" ++ escapeSlash cs - escapeSlash (c:cs) = c : escapeSlash cs - -runSitePlus :: (Happstack m) => SitePlus url (m a) -> m a -runSitePlus sitePlus = - do r <- runSitePlus_ sitePlus - case r of - (Left _) -> mzero - (Right a) -> return a - ------------------------------------------------------------------------------- --- Plugins ------------------------------------------------------------------------------- - -initPlugins :: ClckT SiteURL IO () -initPlugins = - do showFn <- askRouteFn - let mediaCmd' :: forall url m. (Monad m) => (Text -> ClckT url m Builder) - mediaCmd' = mediaCmd (\u p -> showFn (M u) p) - addPreProcessor "media" mediaCmd' - nestURL M $ addMediaAdminMenu - nestURL I $ addIrcBotAdminMenu - dm <- nestURL C $ defaultAdminMenu - mapM_ addAdminMenu dm - hunk ./happstack-dot-com/Main.hs 42 --- Server +-- main hunk ./happstack-dot-com/Main.hs 45 -{- - -The Problem: - -withClckwrks, withMediaConfig, etc, allocate resources and create State types which are needed in order to run clcwrks and other plugins. - -but, we have further plugin initialization that needs to happen, like registering PreProcessor callbacks. - -And, those extra initializations might need to know how to create URLs. - -but, we don't know how to show those urls until we call mkSitePlus -- which requires us to pass in mediaConf. - --} - -setRoot cc path = - case clckTopDir cc of - Nothing -> path - (Just base) -> base path - - -clckwrks :: ClckwrksConfig SiteURL -> IO () -clckwrks cc = - do withClckwrks cc $ \clckState -> - withMediaConfig (clckTopDir cc) (setRoot cc "_uploads") $ \mediaConf -> - let ircConfig = IrcConfig { ircHost = "irc.freenode.net" - , ircPort = 6667 - , ircNick = "synthea" - , ircCommandPrefix = "#" - , ircUser = User { username = "synthea" - , hostname = "happstack.com" - , servername = "irc.freenode.net" - , realname = "happstack.com bot" - } - , ircChannels = Set.singleton "#happs" - } -{- - template' :: forall headers body m. - ( EmbedAsChild (ClckT IrcBotURL m) headers - , EmbedAsChild (ClckT IrcBotURL m) body - ) => - String - -> headers - -> body - -> XMLGenT (ClckT SiteURL m) XML --} - template' = undefined - in - withIrcBotConfig (clckTopDir cc) ircConfig template' (setRoot cc "_irclogs") $ \ircBotConf -> - let -- site = mkSite (clckPageHandler cc) clckState mediaConf - site = mkSite2 cc mediaConf ircBotConf - sitePlus = mkSitePlus (Text.pack $ clckHostname cc) (clckPort cc) Text.empty site - in - do clckState' <- execClckT (siteShowURL sitePlus) clckState $ initPlugins - let sitePlus' = fmap (evalClckT (siteShowURL sitePlus) clckState') sitePlus - tid <- forkIO $ simpleHTTP (nullConf { port = clckPort cc }) (route cc sitePlus') - waitForTermination - killThread tid - -{- --- clckwrks_ :: ClckwrksConfig SiteURL -> (IO (Site SiteURL (ClckT SiteURL (ServerPartT IO) Response) -> IO ())) -> IO () -clckwrks_ cc' f = - do args <- getArgs - let cc = case args of - [] -> cc' - (h:_) -> cc' { clckHostname = h } - withClckwrks cc $ \clckState -> - doMedia $ \site -> --- withMediaConfig Nothing "_uploads" $ \mediaConf -> - let -- site = mkSite (clckPageHandler cc) clckState mediaConf --- site = mkSite2 cc mediaConf - sitePlus = mkSitePlus (Text.pack $ clckHostname cc) (clckPort cc) Text.empty site - in - do clckState' <- execClckT (siteShowURL sitePlus) clckState $ initPlugins - let sitePlus' = fmap (evalClckT (siteShowURL sitePlus) clckState') sitePlus - simpleHTTP (nullConf { port = clckPort cc }) (route cc sitePlus') - where - doMedia cont = - withMediaConfig Nothing "_uplod" $ \mediaConfig -> - let site = mkSite2 cc mediaConf - in cont site - --} - -route :: Happstack m => ClckwrksConfig SiteURL -> SitePlus SiteURL (m Response) -> m Response -route cc sitePlus = - do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6)) - msum $ - [ jsHandlers cc - , dir "favicon.ico" $ notFound (toResponse ()) - , dir "static" $ serveDirectory DisableBrowsing [] (clckStaticDir cc) - , dir "login" $ seeOther ((siteShowURL sitePlus) (C $ Auth $ AuthURL A_Login) []) (toResponse ()) - , dir "admin" $ seeOther ((siteShowURL sitePlus) (C $ Admin Console) []) (toResponse ()) - , dir "blog" $ dir "atom.xml" $ seeOther ((siteShowURL sitePlus) (C $ AtomFeed) []) (toResponse ()) - , dir "blog" $ seeOther ((siteShowURL sitePlus) (C $ Blog) []) (toResponse ()) - , dir "cufp2012" $ seeOther ((siteShowURL sitePlus) (C $ ViewPage (PageId 13)) []) (toResponse ()) - , dir "docs" $ msum - [ dir "crashcourse" $ serveDirectory EnableBrowsing [] "/home/jeremy/public_html/happstack-crashcourse" - , serveDirectory EnableBrowsing [] "/home/jeremy/public_html/happstack/7" - ] - , runSitePlus sitePlus - ] - -{- - -we can't register the pp callbacks instead the nestURL because then -the only callbacks will only be available when that route is active. - -it is 'tricky' to register the callbacks outside, because the -callbacks might require information that is only available 'inside' -the monad. But, of course, that is silly now that we think about -it. Because that monad is only available when processing the route. But when doing the pp, that route may not be the one we are doing. - -So, the reason it is hard to get the monad into the callback is because we shouldn't. The pp has to assume that the route being processed is not one of those. - -Well, that is not actually a problem. The monad is really an environment in which a computation can run. And we can create that environment multiple ways. - -The issue with the MediaT monad is that it includes the MediaURL. And so to work with that, we need to specify how to turn a MediaURL into a SiteURL. - -That is something we normally do in routeSite via 'nestURL M'. But that means we have to repeat ourselves. - -we could have a function like withMediaT to contruct a temporary MediaT monad to be used when registering the callback. Though there is a danger there, because some of the information use to register the callback might become stale. -p -In theory, we would like to do some stuff in the ClckT monad before start listening to incoming requests. However, to run the ClckT monad we need to provide the show function. Normally that is done transparently via implSite / site / etc. - -Though it seems the information we need comes from Site not implSite. --} -routeSite :: ClckwrksConfig u -> MediaConfig -> IrcBotConfig -> SiteURL -> Clck SiteURL Response -routeSite cc mediaConfig ircBotConfig url = - do case url of - (C clckURL) -> nestURL C $ routeClck cc clckURL - (M mediaURL) -> - do showFn <- askRouteFn - -- FIXME: it is a bit silly that we wait this long to set the mediaClckURL - -- would be better to do it before we forkIO on simpleHTTP - nestURL M $ runMediaT (mediaConfig { mediaClckURL = (showFn . C) }) $ routeMedia mediaURL - (I ircBotURL) -> - do showFn <- askRouteFn - let deRoute :: (ClckURL -> [(Text, Maybe Text)] -> Text) -> Clck ClckURL a -> Clck url a - deRoute sf (ClckT (RouteT r)) = (ClckT (RouteT (\nsf -> (r sf)))) - let template' :: ( EmbedAsChild (Clck ClckURL) headers - , EmbedAsChild (Clck ClckURL) body - ) => String - -> headers - -> body - -> XMLGenT (Clck IrcBotURL) XML - template' ttl hdrs bdy = - XMLGenT $ (deRoute (showFn . C) $ unXMLGenT $ template ttl hdrs bdy) - - nestURL I $ runIrcBotT (ircBotConfig { ircBotClckURL = (showFn . C) - , ircBotPageTemplate = template' - }) $ routeIrcBot ircBotURL -{- -mkSite :: ClckwrksConfig u -> ClckState -> MediaConfig -> Site SiteURL (ServerPart Response) -mkSite cc clckState media = setDefault (C $ ViewPage $ PageId 1) $ mkSitePI route' - where - route' f u = - evalStateT (unRouteT (unClckT $ routeSite cc media u) f) clckState --} --- FIXME: something seems weird here.. we do not use the 'f' in route' -mkSite2 :: ClckwrksConfig u -> MediaConfig -> IrcBotConfig -> Site SiteURL (ClckT SiteURL (ServerPartT IO) Response) -mkSite2 cc mediaConfig ircBotConfig = setDefault (C $ ViewPageSlug (PageId 1) (Slug Text.empty)) $ mkSitePI route' - where - route' :: (SiteURL -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -> SiteURL -> ClckT SiteURL (ServerPartT IO) Response - route' f url = - routeSite cc mediaConfig ircBotConfig url - -#ifdef PLUGINS hunk ./happstack-dot-com/Main.hs 47 - do ph <- initPlugins - putStrLn "Dynamic Server Started." - defCC <- clckwrksConfig - cc <- getClckwrksConfig (clckwrksOpts defCC) defCC - clckwrks (cc { clckPageHandler = dynamicPageHandler ph }) - -dynamicPageHandler :: PluginHandle -> Clck ClckURL Response -dynamicPageHandler ph = - do fp <- themePath <$> get - withMonadIOFile "PageMapper.hs" "pageMapper" ph (\pc -> pc { pcGHCArgs = [ "-i" ++ fp] }) notLoaded page - where - page :: [String] -> XMLGenT (Clck url) XML -> Clck url Response - page _errs (XMLGenT part) = toResponse <$> part - notLoaded errs = - internalServerError $ toResponse $ unlines errs -#else -main :: IO () -main = - do putStrLn "Static Server Started." - defCC <- clckwrksConfig - cc <- getClckwrksConfig (clckwrksOpts defCC) defCC - clckwrks cc - -staticPageHandler :: Clck ClckURL Response -staticPageHandler = toResponse <$> unXMLGenT pageMapper -#endif - -staticBlogHandler :: Clck ClckURL Response -staticBlogHandler = toResponse <$> unXMLGenT Blog.page + do args <- getArgs + f <- parseArgs (clckwrksOpts clckwrksConfig) args + simpleClckwrks (f clckwrksConfig) hunk ./happstack-dot-com/Main.hs 51 +initHook :: Text + -> ClckState + -> ClckwrksConfig + -> IO (ClckState, ClckwrksConfig) +initHook baseURI clckState cc = + do let p = plugins clckState + initPlugin p baseURI clckPlugin + initPlugin p baseURI ircBotPlugin + initPlugin p baseURI mediaPlugin + setTheme p (Just theme) + return (clckState, cc) addfile ./happstack-dot-com/debian/Debianize.hs hunk ./happstack-dot-com/debian/Debianize.hs 1 +import Data.List (isPrefixOf) +import Debian.Relation (BinPkgName(..)) +import Distribution.Debian (Flags(..), defaultFlags, Executable(..), Server(..), Site(..), tightDependencyFixup) +import Distribution.Debian.DebHelper (DebAtom(..)) +import Distribution.Debian.Debianize +import Distribution.Debian.Server (databaseDirectory) +import Distribution.Simple +import qualified Paths_clckwrks as Clckwrks + +main :: IO () +main = + do jstreePath <- Clckwrks.getDataFileName "jstree" + json2Path <- Clckwrks.getDataFileName "json2" + Distribution.Debian.Debianize.debianize $ + defaultFlags { missingDependencies = ["libghc-clckwrks-theme-happstack-doc"] + , executablePackages = map (theSite jstreePath json2Path "happstack-dot-com-server") serverNames ++ [backups] + , haddock = True + , revision = "" + , modifyAtoms = \ atoms -> + map fixRulesHead atoms ++ + concatMap + (\ package -> tightDependencyFixup package + -- For each pair (A, B) make sure that this package requires the + -- same exact version of package B as the version of A currently + -- installed during the build. + [("libghc-clckwrks-theme-happstack-dev", "haskell-clckwrks-theme-happstack-utils"), + ("libghc-clckwrks-plugin-media-dev", "haskell-clckwrks-plugin-media-utils"), + ("libghc-clckwrks-plugin-ircbot-dev", "haskell-clckwrks-plugin-ircbot-utils"), + ("libghc-clckwrks-dev", "haskell-clckwrks-utils")]) + serverNames + } + where + serverNames = map BinPkgName ["happstack-dot-com-production"] -- , "clckwrks-dot-com-staging", "clckwrks-dot-com-development"] + -- Insert a line just above the debhelper.mk include + fixRulesHead (DebRulesHead s) = DebRulesHead $ unlines $ concat $ + map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" + then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] + else [line]) (lines s) + fixRulesHead x = x + +theSite :: FilePath -> FilePath -> String -> BinPkgName -> Executable +theSite jstreePath json2Path name (BinPkgName deb) = + let this = Executable + { debName = deb + , execName = name + , destName = deb + , sourceDir = Nothing + , destDir = Nothing + , execServer = + Just (Server + { hostname = + case deb of + "happstack-dot-com-production" -> hostname + _ -> hostname + , port = portNum + , site = + case deb of + "happstack-dot-com-production" -> Just (Site { domain = hostname, serverAdmin = "logic@seereason.com" }) + _ -> Nothing + , headerMessage = "Generated by happstack-dot-com/Setup.hs" + , retry = "60" + , flags = [ "--http-port", show portNum + , "--hide-port" + , "--hostname", hostname + , "--top", databaseDirectory this + , "--enable-analytics" + , "--jquery-path", "/usr/share/javascript/jquery/" + , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" + , "--jstree-path", jstreePath + , "--json2-path",json2Path + ] + }) } + in this + where + hostname = "happstack.com" + portNum = + case deb of + "happstack-dot-com-production" -> 9028 +-- "happstack-dot-com-staging" -> 9038 +-- "happstack-dot-com-development" -> 9039 + _ -> error $ "Unexpected package name: " ++ name + +backups = + Executable + { execName = "happstack-dot-com-backups" + , destName = "happstack-dot-com-backups" + , debName = "happstack-dot-com-backups" + , sourceDir = Nothing + , destDir = Just "/etc/cron.hourly" + , execServer = Nothing } hunk ./happstack-dot-com/debian/changelog 1 -haskell-happstack-dot-com (0.1.19) unstable; urgency=low +haskell-happstack-dot-com (0.2.0) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 3 - * Bumped dependency ranges + * Debianization generated by cabal-debian + * Debianization generated by cabal-debian + * Debianization generated by cabal-debian + * Debianization generated by cabal-debian + * Debianization generated by cabal-debian hunk ./happstack-dot-com/debian/changelog 9 - -- Jeremy Shaw Fri, 19 Oct 2012 18:03:34 -0500 hunk ./happstack-dot-com/debian/changelog 10 -haskell-happstack-dot-com (0.1.18) unstable; urgency=low + -- Jeremy Shaw Mon, 03 Dec 2012 13:09:35 -0600 hunk ./happstack-dot-com/debian/changelog 12 - * Added twitter widget to homepage +haskell-clckwrks-dot-com (0.1.18) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 14 - -- Jeremy Shaw Tue, 02 Oct 2012 16:43:22 -0500 + * Allow most recent containers hunk ./happstack-dot-com/debian/changelog 16 -haskell-happstack-dot-com (0.1.17) unstable; urgency=low + -- Jeremy Shaw Fri, 05 Oct 2012 18:49:33 -0500 + +haskell-clckwrks-dot-com (0.1.17) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 23 - -- Jeremy Shaw Wed, 22 Aug 2012 12:10:01 -0500 + -- Jeremy Shaw Wed, 22 Aug 2012 12:08:33 -0500 hunk ./happstack-dot-com/debian/changelog 25 -haskell-happstack-dot-com (0.1.16) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.16) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 27 - * Updated clckwrks 0.11 (page slugs) + * Now with support for page slugs hunk ./happstack-dot-com/debian/changelog 29 - -- Jeremy Shaw Fri, 10 Aug 2012 15:21:11 -0500 + -- Jeremy Shaw Fri, 10 Aug 2012 15:13:24 -0500 hunk ./happstack-dot-com/debian/changelog 31 -haskell-happstack-dot-com (0.1.14) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.15) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 33 - * Updated to clckwrks 0.10.* - * Disable building of backups by default in .cabal but enable it in debian/rules + * updated to latest clcwrks hunk ./happstack-dot-com/debian/changelog 35 - -- Jeremy Shaw Tue, 19 Jun 2012 17:50:31 -0500 + -- Jeremy Shaw Tue, 19 Jun 2012 17:48:37 -0500 hunk ./happstack-dot-com/debian/changelog 37 -haskell-happstack-dot-com (0.1.10) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.13) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 39 - * happstack-dot-com-server: Autogenerate some *-utils Depends + * Bumped by accident, but whatever. hunk ./happstack-dot-com/debian/changelog 41 - -- Jeremy Shaw Mon, 21 May 2012 19:16:44 -0500 + -- Jeremy Shaw Sat, 09 Jun 2012 17:52:18 -0500 hunk ./happstack-dot-com/debian/changelog 43 -haskell-happstack-dot-com (0.1.5) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.11) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 45 - * Bump version to match cabal file. + * Who knows hunk ./happstack-dot-com/debian/changelog 47 - -- David Fox Mon, 09 Apr 2012 08:14:26 -0700 + -- Jeremy Shaw Tue, 05 Jun 2012 16:39:52 -0500 hunk ./happstack-dot-com/debian/changelog 49 -haskell-happstack-dot-com (0.1.3) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.6) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 51 - * Add a backup script package. + * Also generate depends on haskell-clckwrks-utils hunk ./happstack-dot-com/debian/changelog 53 - -- David Fox Wed, 28 Mar 2012 15:56:06 -0700 + -- Jeremy Shaw Mon, 21 May 2012 18:22:27 -0500 hunk ./happstack-dot-com/debian/changelog 55 -haskell-happstack-dot-com (0.1.2) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.5) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 57 - * Make happstack-dot-com-production conflict with and replace the old - server happstackdotcom-production. + * Fixed debian/rules so that it generates the depends for + haskell-clckwrks-theme-clckwrks-utils hunk ./happstack-dot-com/debian/changelog 60 - -- David Fox Wed, 28 Mar 2012 14:55:42 -0700 + -- Jeremy Shaw Mon, 21 May 2012 16:31:20 -0500 hunk ./happstack-dot-com/debian/changelog 62 -haskell-happstack-dot-com (0.1.1-2) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.4) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 64 - * Bump version to trump an upload. + * Added missing 'cpp-options: -DCABAL' to .cabal + * Added missing depends on haskell-clckwrks-theme-clckwrks-utils hunk ./happstack-dot-com/debian/changelog 67 - -- David Fox Tue, 27 Mar 2012 15:53:30 -0700 + -- Jeremy Shaw Mon, 21 May 2012 15:07:35 -0500 hunk ./happstack-dot-com/debian/changelog 69 -haskell-happstack-dot-com (0.1-1) unstable; urgency=low +haskell-clckwrks-dot-com (0.1.3) unstable; urgency=low hunk ./happstack-dot-com/debian/changelog 71 - * Debianization generated by cabal-debian + * Updated command-line processing to match what happstack-debianization expects + + -- Jeremy Shaw Mon, 21 May 2012 12:39:45 -0500 hunk ./happstack-dot-com/debian/changelog 75 - -- David Fox Tue, 27 Mar 2012 09:12:40 -0700 +haskell-clckwrks-dot-com (0.1.2-1~hackage1) unstable; urgency=low + + * Debianization generated by cabal-debian hunk ./happstack-dot-com/debian/changelog 79 + -- Jeremy Shaw Sun, 20 May 2012 13:50:50 -0500 hunk ./happstack-dot-com/debian/compat 1 -7 + rmfile ./happstack-dot-com/debian/compat hunk ./happstack-dot-com/debian/control 1 -Source: haskell-happstack-dot-com -Priority: extra -Section: haskell -Maintainer: David Fox -Build-Depends: debhelper (>= 7.0), - haskell-devscripts (>= 0.8), - cdbs, - ghc, - ghc-prof, - libghc-archive-prof, - libghc-base-dev (<< 5) | ghc, - libghc-base-prof (<< 5) | ghc-prof, - libghc-bytestring-dev (>> 0.9) | ghc, - libghc-bytestring-dev (<= 0.10) | ghc, - libghc-bytestring-prof (>> 0.9) | ghc-prof, - libghc-bytestring-prof (<= 0.10) | ghc-prof, - libghc-clckwrks-dev, - libghc-clckwrks-prof, - libghc-clckwrks-plugin-ircbot-dev, - libghc-clckwrks-plugin-ircbot-prof, - libghc-clckwrks-plugin-media-dev, - libghc-clckwrks-plugin-media-prof, - libghc-clckwrks-theme-happstack-dev, - libghc-clckwrks-theme-happstack-prof, - libghc-containers-dev (>> 0.4) | ghc, - libghc-containers-dev (<= 0.5) | ghc, - libghc-containers-prof (>> 0.4) | ghc-prof, - libghc-containers-prof (<= 0.5) | ghc-prof, - libghc-extra-prof, - libghc-filepath-dev (>> 1.3) | ghc, - libghc-filepath-dev (<= 1.4) | ghc, - libghc-filepath-prof (>> 1.3) | ghc-prof, - libghc-filepath-prof (<= 1.4) | ghc-prof, - libghc-mtl-dev (>> 2.0), - libghc-mtl-prof (>> 2.0), - libghc-text-dev (>> 0.11), - libghc-text-dev (<= 0.12), - libghc-text-prof (>> 0.11), - libghc-text-prof (<= 0.12), - libghc-web-routes-happstack-dev, - libghc-web-routes-happstack-prof, - libghc-web-routes-th-dev (>> 0.21), - libghc-web-routes-th-prof (>> 0.21), - happstack-debianization (>= 0.13) -Build-Depends-Indep: ghc-doc, - libghc-archive-doc, - libghc-base-doc (<< 5) | ghc-doc, - libghc-bytestring-doc (>> 0.9) | ghc-doc, - libghc-bytestring-doc (<= 0.10) | ghc-doc, - libghc-clckwrks-doc, - libghc-clckwrks-plugin-media-doc, - libghc-clckwrks-theme-happstack-doc, - libghc-containers-doc (>> 0.4) | ghc-doc, - libghc-containers-doc (<= 0.5) | ghc-doc, - libghc-extra-doc, - libghc-filepath-doc (>> 1.3) | ghc-doc, - libghc-filepath-doc (<= 1.4) | ghc-doc, - libghc-mtl-doc (>> 2.0), - libghc-text-doc (>> 0.11), - libghc-text-doc (<= 0.12), - libghc-web-routes-happstack-doc, - libghc-web-routes-th-doc (>> 0.21) -Standards-Version: 3.9.1 -Homepage: http://www.happstack.com/ - -Package: happstack-dot-com-server -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends} -Description: happstack.com server - -Package: happstack-dot-com-production -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, happstack-dot-com-server -Conflicts: happstack-dot-com-staging -Replaces: happstack-dot-com-staging -Description: happstack.com production installation - -Package: happstack-dot-com-staging -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, happstack-dot-com-server -Conflicts: happstack-dot-com-production -Replaces: happstack-dot-com-production -Description: happstack.com staging installation - -Package: happstack-dot-com-testing -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, happstack-dot-com-server -Description: happstack.com testing installation - -Package: happstack-dot-com-backups -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, anacron -Description: backup program for happstack-dot-com site - Install this somewhere other than where the server is running get - automated backups of the database. rmfile ./happstack-dot-com/debian/control hunk ./happstack-dot-com/debian/copyright 1 -Copyright (c)2011, SeeReason Partners LLC. - -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 Jeremy Shaw 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. rmfile ./happstack-dot-com/debian/copyright hunk ./happstack-dot-com/debian/rules 1 -#!/usr/bin/make -f - -DEB_CABAL_PACKAGE = happstack-dot-com -DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups - -include /usr/share/cdbs/1/rules/debhelper.mk -include /usr/share/cdbs/1/class/hlibrary.mk - -build/happstack-dot-com-server:: build-ghc-stamp -binary-fixup/happstack-dot-com-server:: - install -m 755 -s -D dist-ghc/build/happstack-server/happstack-server debian/happstack-dot-com-server/usr/bin/happstack-dot-com-server || true - echo -n 'haskell:Depends=' >> debian/happstack-dot-com-server.substvars - dpkg-query -W -f='haskell-clckwrks-theme-happstack-utils (=$${Version})' libghc-clckwrks-theme-happstack-dev >> debian/happstack-dot-com-server.substvars - dpkg-query -W -f=', haskell-clckwrks-plugin-media-utils (=$${Version})' libghc-clckwrks-plugin-media-dev >> debian/clckwrks-dot-com-server.substvars - dpkg-query -W -f=', haskell-clckwrks-utils (=$${Version})\n' libghc-clckwrks-dev >> debian/happstack-dot-com-server.substvars - -makebuilddir:: - SITENAME=happstack.com HOSTNAME=seereason.com SERVERADMIN=partners@seereason.com PROXYPORT=9028 TESTINGPORT=8000 happstack-debianization-install - -binary-fixup/happstack-dot-com-backups:: - install -Dps -m 755 dist-ghc/build/happstack-dot-com-backups/happstack-dot-com-backups debian/happstack-dot-com-backups/etc/cron.hourly/happstack-dot-com rmfile ./happstack-dot-com/debian/rules hunk ./happstack-dot-com/happstack-dot-com.cabal 2 -Version: 0.1.19 +Version: 0.2.0 hunk ./happstack-dot-com/happstack-dot-com.cabal 9 -Maintainer: jeremy@n-heptane.com +Maintainer: Jeremy Shaw hunk ./happstack-dot-com/happstack-dot-com.cabal 23 -Executable happstack-server +Executable happstack-dot-com-server hunk ./happstack-dot-com/happstack-dot-com.cabal 29 - base < 5, - bytestring >= 0.9 && < 0.11, - clckwrks == 0.12.*, - clckwrks-plugin-media == 0.2.*, - clckwrks-plugin-ircbot == 0.2.*, - containers >= 0.4 && < 0.6, - filepath == 1.3.*, - happstack-server >= 7.0.4, - mtl >= 2.0, - network >= 2.3 && < 2.5, - text == 0.11.*, - web-routes-happstack == 0.23.*, - web-routes-th >= 0.21 - - if flag(plugins) - Build-depends: - mtl >= 2.0, - plugins-auto > 0.0.1 - cpp-options: -DPLUGINS - else - Build-depends: - clckwrks-theme-happstack + base >4 && < 5, + bytestring >= 0.9 && < 0.11, + clckwrks == 0.13.*, + clckwrks-plugin-media == 0.3.*, + clckwrks-plugin-ircbot == 0.3.*, + clckwrks-theme-happstack == 0.2.*, + containers >= 0.4 && < 0.6, + happstack-server >= 7.0.4, + mtl >= 2.0, + text == 0.11.*, + web-plugins == 0.1.* hunk ./happstack-dot-com/happstack-dot-com.cabal 46 - Build-depends: archive >= 1.2.9, base, Extra + Build-depends: base > 4 && < 5, + archive >= 1.2.9, + Extra