**20121115221801 Ignore-this: 4dd0afde0f5a512a34f5862d3562600 ] hunk ./clckwrks-theme-clckwrks/Theme/Blog.hs 1 -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -F -pgmFtrhsx #-} -module Theme.Blog where - -import Clckwrks -import Data.Text (unpack) -import Theme.Template - -postsHTML :: XMLGenT (Clck ClckURL) XML -postsHTML = - do posts <- getPosts -

- <% mapM postHTML posts %> - - -postHTML :: Page -> XMLGenT (Clck ClckURL) XML -postHTML Page{..} = -

<% pageTitle %>

- <% pageDate %> - <% pageSrc %> -

permalink

- -page :: XMLGenT (Clck ClckURL) XML -page = - do ttl <- lift getBlogTitle - template (unpack ttl) () $ - <%> -

<% ttl %>

- <% postsHTML %> -

- rmfile ./clckwrks-theme-clckwrks/Theme/Blog.hs hunk ./clckwrks-theme-clckwrks/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 %> -

clckwrks

-{- -

--} -

---
“runs smoothly and invisibly” - Katherine Durkes
-
“An open-source CMS you can trust, built with the dexterity of Haskell.”
-

- - <% getPageContent %> - -

- <% summaryBox (PageId 8) "Why?" "philosophy-icon.png" %> - <% summaryBox (PageId 3) "Get Started" "7-icon.png" %> - <% summaryBox (PageId 2) "Get Involved" "8-icon.png" %> -

- -

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

<% getPageTitle %>

- <% getPageContent %> - rmfile ./clckwrks-theme-clckwrks/Theme/Page.hs hunk ./clckwrks-theme-clckwrks/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 = - template' title headers $ -

- <% body %> -

- -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-clckwrks/Theme/Template.hs rmdir ./clckwrks-theme-clckwrks/Theme hunk ./clckwrks-dot-com/debian/changelog 1 -haskell-clckwrks-dot-com (0.1.18) unstable; urgency=low - - * Allow most recent containers - - -- Jeremy Shaw Fri, 05 Oct 2012 18:49:33 -0500 - -haskell-clckwrks-dot-com (0.1.17) unstable; urgency=low - - * Updated to clckwrks 0.12 - * Added waitForTermination - - -- Jeremy Shaw Wed, 22 Aug 2012 12:08:33 -0500 - -haskell-clckwrks-dot-com (0.1.16) unstable; urgency=low - - * Now with support for page slugs - - -- Jeremy Shaw Fri, 10 Aug 2012 15:13:24 -0500 - -haskell-clckwrks-dot-com (0.1.15) unstable; urgency=low - - * updated to latest clcwrks - - -- Jeremy Shaw Tue, 19 Jun 2012 17:48:37 -0500 - -haskell-clckwrks-dot-com (0.1.13) unstable; urgency=low - - * Bumped by accident, but whatever. - - -- Jeremy Shaw Sat, 09 Jun 2012 17:52:18 -0500 - -haskell-clckwrks-dot-com (0.1.11) unstable; urgency=low - - * Who knows - - -- Jeremy Shaw Tue, 05 Jun 2012 16:39:52 -0500 - -haskell-clckwrks-dot-com (0.1.6) unstable; urgency=low - - * Also generate depends on haskell-clckwrks-utils - - -- Jeremy Shaw Mon, 21 May 2012 18:22:27 -0500 - -haskell-clckwrks-dot-com (0.1.5) unstable; urgency=low - - * Fixed debian/rules so that it generates the depends for - haskell-clckwrks-theme-clckwrks-utils - - -- Jeremy Shaw Mon, 21 May 2012 16:31:20 -0500 - -haskell-clckwrks-dot-com (0.1.4) unstable; urgency=low - - * Added missing 'cpp-options: -DCABAL' to .cabal - * Added missing depends on haskell-clckwrks-theme-clckwrks-utils - - -- Jeremy Shaw Mon, 21 May 2012 15:07:35 -0500 - -haskell-clckwrks-dot-com (0.1.3) unstable; urgency=low - - * Updated command-line processing to match what happstack-debianization expects - - -- Jeremy Shaw Mon, 21 May 2012 12:39:45 -0500 - -haskell-clckwrks-dot-com (0.1.2-1~hackage1) unstable; urgency=low - - * Debianization generated by cabal-debian - - -- Jeremy Shaw Sun, 20 May 2012 13:50:50 -0500 - rmfile ./clckwrks-dot-com/debian/changelog hunk ./clckwrks-dot-com/debian/compat 1 -7 + rmfile ./clckwrks-dot-com/debian/compat hunk ./clckwrks-dot-com/debian/control 1 -Source: haskell-clckwrks-dot-com -Priority: extra -Section: haskell -Maintainer: Jeremy Shaw -Build-Depends: debhelper (>= 7.0), - haskell-devscripts (>= 0.8), - cdbs, - ghc, - ghc-prof, - libghc-extra-dev, - libghc-extra-prof, - libghc-archive-dev (>= 1.2.9), - libghc-archive-prof (>= 1.2.9), - libghc-base-dev (<< 5) | ghc, - libghc-base-prof (<< 5) | ghc-prof, - libghc-bytestring-dev (>= 0.9) | ghc, - libghc-bytestring-prof (>= 0.9) | ghc-prof, - libghc-clckwrks-prof, - libghc-clckwrks-plugin-media-dev (>= 0.2), - libghc-clckwrks-plugin-media-dev (<< 0.3), - libghc-clckwrks-plugin-media-prof (>= 0.2), - libghc-clckwrks-plugin-media-prof (<< 0.3), - libghc-clckwrks-plugin-bugs-prof (>= 0.2), - libghc-clckwrks-plugin-bugs-prof (<< 0.3), - libghc-clckwrks-theme-clckwrks-dev, - libghc-clckwrks-theme-clckwrks-prof, - libghc-containers-dev (>= 0.4) | ghc, - libghc-containers-prof (>= 0.4) | ghc-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-dev (<< 2.3), - libghc-mtl-prof (>= 2.0), - libghc-mtl-prof (<< 2.3), - libghc-network-dev (>= 2.3), - libghc-network-dev (<< 2.5), - libghc-network-prof (>= 2.3), - libghc-network-prof (<< 2.5), - libghc-text-dev (>= 0.11), - libghc-text-dev (<< 0.12), - libghc-text-prof (>= 0.11), - libghc-text-prof (<< 0.12), - libghc-web-routes-dev (>= 0.27), - libghc-web-routes-dev (<< 0.28), - libghc-web-routes-prof (>= 0.27), - libghc-web-routes-prof (<< 0.28), - libghc-web-routes-happstack-dev (>= 0.23), - libghc-web-routes-happstack-dev (<< 0.24), - libghc-web-routes-happstack-prof (>= 0.23), - libghc-web-routes-happstack-prof (<< 0.24), - libghc-web-routes-th-dev (>= 0.21), - libghc-web-routes-th-prof (>= 0.21), - happstack-debianization (>= 0.13) -Build-Depends-Indep: ghc-doc, - libghc-extra-doc, - libghc-archive-doc (>= 1.2.9), - libghc-base-doc (<< 5) | ghc-doc, - libghc-bytestring-doc (>= 0.9) | ghc-doc, - libghc-clckwrks-doc, - libghc-clckwrks-plugin-media-doc (>= 0.2), - libghc-clckwrks-plugin-media-doc (<< 0.3), - libghc-clckwrks-plugin-bugs-doc, - libghc-clckwrks-theme-clckwrks-doc, - libghc-containers-doc (>= 0.4) | ghc-doc, - libghc-filepath-doc (>= 1.3) | ghc-doc, - libghc-filepath-doc (<< 1.4) | ghc-doc, - libghc-mtl-doc (>= 2.0), - libghc-mtl-doc (<< 2.3), - libghc-network-doc (>= 2.3), - libghc-network-doc (<< 2.5), - libghc-text-doc (>= 0.11), - libghc-text-doc (<< 0.12), - libghc-web-routes-doc (>= 0.27), - libghc-web-routes-doc (<< 0.28), - libghc-web-routes-happstack-doc (>= 0.23), - libghc-web-routes-happstack-doc (<< 0.24), - libghc-web-routes-th-doc (>= 0.21) -Standards-Version: 3.9.1 -Homepage: http://clckwrks.com/ - -Package: clckwrks-dot-com-utils -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends} -Description: clckwrks.com - -Package: clckwrks-dot-com-production -Architecture: all -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, clckwrks-dot-com-server -Description: Server clckwrks.com - Server clckwrks.com - . - Author: David Fox , Clifford Beshers - Upstream-Maintainer: Clifford Beshers - -Package: clckwrks-dot-com-staging -Architecture: all -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends} -Description: Server clckwrks.com - Server clckwrks.com - . - Author: David Fox , Clifford Beshers - Upstream-Maintainer: Clifford Beshers - -Package: clckwrks-dot-com-testing -Architecture: all -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends} -Description: Server clckwrks.com - Server clckwrks.com - . - Author: David Fox , Clifford Beshers - Upstream-Maintainer: Clifford Beshers - -Package: clckwrks-dot-com-server -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, libjs-jquery, libjs-jquery-ui -Description: Server clckwrks.com - Server clckwrks.com - . - Author: David Fox , Clifford Beshers - Upstream-Maintainer: Clifford Beshers - -Package: clckwrks-dot-com-backups -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, anacron -Description: backup program for the clckwrks.com site - Install this somewhere other than where the server is running get - automated backups of the database. rmfile ./clckwrks-dot-com/debian/control hunk ./clckwrks-dot-com/debian/copyright 1 -Copyright (c)2011, Jeremy Shaw - -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 ./clckwrks-dot-com/debian/copyright hunk ./clckwrks-dot-com/debian/rules 1 -#!/usr/bin/make -f - -DEB_CABAL_PACKAGE = clckwrks-dot-com -DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups - -include /usr/share/cdbs/1/rules/debhelper.mk -include /usr/share/cdbs/1/class/hlibrary.mk - -makebuilddir:: - SITENAME=clckwrks.com SERVERADMIN=jeremy@seereason.com PROXYPORT=9029 TESTINGPORT=8000 happstack-debianization-install - -# Required for packages with no Library section in their cabal file -build/clckwrks-dot-com-server:: build-ghc-stamp - -binary-fixup/clckwrks-dot-com-server:: - install -Dp -m 755 dist-ghc/build/clckwrks-dot-com-server/clckwrks-dot-com-server debian/clckwrks-dot-com-server/usr/bin/clckwrks-dot-com-server - echo -n 'haskell:Depends=' >> debian/clckwrks-dot-com-server.substvars - dpkg-query -W -f='haskell-clckwrks-theme-clckwrks-utils (=$${Version})' libghc-clckwrks-theme-clckwrks-dev >> debian/clckwrks-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-plugin-bugs-utils (=$${Version})' libghc-clckwrks-plugin-bugs-dev >> debian/clckwrks-dot-com-server.substvars - dpkg-query -W -f=', haskell-clckwrks-utils (=$${Version})\n' libghc-clckwrks-dev >> debian/clckwrks-dot-com-server.substvars - -binary-fixup/clckwrks-dot-com-data:: - find theme -type f | while read i; do \ - install -Dp $$i debian/clckwrks-dot-com-data/usr/share/clckwrks-dot-com-data/$$i; \ - done - -binary-fixup/clckwrks-dot-com-backups:: - install -Dps -m 755 dist-ghc/build/clckwrks-dot-com-backups/clckwrks-dot-com-backups debian/clckwrks-dot-com-backups/etc/cron.hourly/clckwrks-dot-com rmfile ./clckwrks-dot-com/debian/rules rmdir ./clckwrks-dot-com/debian hunk ./clckwrks-dot-com/Backups.hs 1 -module Main where - -import System.Archive.Site (BackupTarget(..), backup) - -main = backup (BackupTarget {app = "clckwrks-dot-com-production", user = "upload", host = "seereason.com", keep = 50}) rmfile ./clckwrks-dot-com/Backups.hs hunk ./clckwrks-dot-com/LICENSE 1 -Copyright (c)2011, Jeremy Shaw +Copyright (c) 2012, Jeremy Shaw hunk ./clckwrks-dot-com/Main.hs 1 -{-# LANGUAGE CPP, FlexibleContexts, RankNTypes, RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} hunk ./clckwrks-dot-com/Main.hs 4 -import Clckwrks -import Clckwrks.Admin.Template (defaultAdminMenu) -import Clckwrks.Bugs -import Clckwrks.Bugs.PreProcess (bugsCmd) -import Clckwrks.Server -import Clckwrks.Media +import Clckwrks.URL +import Clckwrks.Admin.Template hunk ./clckwrks-dot-com/Main.hs 7 -import Clckwrks.Media.PreProcess (mediaCmd) -import Clckwrks.Page.PreProcess (pageCmd) -import Control.Concurrent (forkIO, killThread) -import Control.Monad.Reader (ReaderT) -import Control.Monad.State (evalStateT, get, modify) -import qualified Data.ByteString.Char8 as C -import Data.List (intercalate) +import Clckwrks.Server +import Clckwrks.Plugin +import Control.Applicative ((<$>)) +import Control.Monad.Trans +import Theme hunk ./clckwrks-dot-com/Main.hs 13 -import Data.Maybe (fromMaybe) -import Data.Monoid (mappend) -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) hunk ./clckwrks-dot-com/Main.hs 14 -import Happstack.Server.SimpleHTTP (waitForTermination) -import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI) -#ifdef CABAL -import qualified Paths_clckwrks as Clckwrks -import qualified Paths_clckwrks_plugin_media as Media -import qualified Paths_clckwrks_plugin_bugs as Bugs -import qualified Paths_clckwrks_theme_clckwrks as Theme -#endif -import System.Console.GetOpt -import System.Directory (doesFileExist) -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 - ------------------------------------------------------------------------------- --- 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 [] ["bugs-data-path"] (ReqArg setBugsDataPath "path") ("path to bugs theme directory, default: " ++ show (Map.lookup "bugs" $ clckPluginDir 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 } - setBugsDataPath str = ModifyConfig $ \c -> c { clckPluginDir = Map.insert "bugs" str (clckPluginDir c) } - --- | 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 -#ifdef CABAL - clckDir <- Clckwrks.getDataDir - themeDir <- Theme.getDataDir - mediaDir <- Media.getDataDir - bugsDir <- Bugs.getDataDir -#else - let clckDir = "../clckwrks/" - themeDir = "../clckwrks-theme-clckwrks/" - mediaDir = "../clckwrks-plugin-media/" - bugsDir = "../clckwrks-plugin-bugs/" -#endif - 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) - ,("bugs" , bugsDir) - ] - , 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) +import Happstack.Server +import Web.Plugin.Core hunk ./clckwrks-dot-com/Main.hs 17 ------------------------------------------------------------------------------- --- SitePlus ------------------------------------------------------------------------------- - -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 ClckURL +clckwrksConfig = ClckwrksConfig + { clckHostname = "localhost" + , clckPort = 8000 + , clckURL = id + , clckJQueryPath = "" + , clckJQueryUIPath = "" + , clckJSTreePath = "" + , clckJSON2Path = "" + , clckThemeDir = "../clckwrks-theme-clckwrks" + , clckPluginDir = Map.empty + , clckStaticDir = "../clckwrks/static" + , clckTopDir = Nothing + , clckEnableAnalytics = False + , clckInitHook = initHook hunk ./clckwrks-dot-com/Main.hs 34 -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 == 9029 - 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 - -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' - - let bugsCmd' :: forall url m. (Functor m, Monad m) => (Text -> ClckT url m Builder) - bugsCmd' = bugsCmd (\u p -> showFn (B u) p) - addPreProcessor "bugs" bugsCmd' - - let pageCmd' :: forall url m. (Functor m, MonadIO m) => (Text -> ClckT url m Builder) - pageCmd' = pageCmd (\u p -> showFn (C u) p) - addPreProcessor "page" pageCmd' - - nestURL M $ addMediaAdminMenu - - dm <- nestURL C $ defaultAdminMenu - mapM_ addAdminMenu dm - -clckwrks :: ClckwrksConfig SiteURL -> IO () -clckwrks cc = - do checkResources cc - withClckwrks cc $ \clckState -> - withMediaConfig (fmap (\p -> p "_state") $ clckTopDir cc ) (fromMaybe "" (clckTopDir cc) "_media_uploads") $ \mediaConf -> - withBugsConfig (fmap (\p -> p "_state") $ clckTopDir cc ) (fromMaybe "" (clckTopDir cc) "_bugs_attachments") $ \bugsConf -> - let -- site = mkSite (clckPageHandler cc) clckState mediaConf - site = mkSite2 cc mediaConf bugsConf - 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 - putStrLn $ "Listening on port " ++ show (clckPort cc) - tid <- forkIO $ simpleHTTP (nullConf { port = clckPort cc }) (route cc sitePlus') - waitForTermination - killThread tid - -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 ()) - , 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. - -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 -> BugsConfig -> SiteURL -> Clck SiteURL Response -routeSite cc mediaConfig bugsConfig 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 - (B bugsURL) -> - 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 BugsM headers - , EmbedAsChild BugsM body - ) => String - -> headers - -> body - -> XMLGenT BugsM XML - template' ttl hdrs bdy = - do hdrXml <- map unClckChild <$> asChild hdrs - bdyXml <- map unClckChild <$> asChild bdy - mapXMLGenT (mapClckT lift . (deRoute (showFn . C))) $ template ttl hdrXml bdyXml - - nestURL B $ runBugsT (bugsConfig { bugsClckURL = (showFn . C) - , bugsPageTemplate = template' - }) $ routeBugs bugsURL - --- FIXME: something seems weird here.. we do not use the 'f' in route' -mkSite2 :: ClckwrksConfig u -> MediaConfig -> BugsConfig -> Site SiteURL (ClckT SiteURL (ServerPartT IO) Response) -mkSite2 cc mediaConfig bugsConfig = 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 bugsConfig url - - -#ifdef PLUGINS -main :: IO () -main = - 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 hunk ./clckwrks-dot-com/Main.hs 35 -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 - ------------------------------------------------------------------------------- --- javascript check ------------------------------------------------------------------------------- - -checkResources :: ClckwrksConfig url -> IO () -checkResources cc = - do let jquery = (clckJQueryPath cc) "jquery.js" - checkResource jquery $ unlines [ "Could not find: " ++ jquery - , "Please make sure jquery is installed. Use --jquery-path to set the path." - , "Download from http://jquery.com/" - ] - let json2 = (clckJSON2Path cc) "json2.js" - checkResource json2 $ unlines [ "Could not find: " ++ json2 - , "Please make sure json2.js is installed. Use --json2-path to set the path." - , "Download from https://raw.github.com/douglascrockford/JSON-js/master/json2.js" - ] - - let jstree = (clckJSTreePath cc) "jquery.jstree.js" - checkResource jstree $ unlines [ "Could not find: " ++ jstree - , "Please make sure jstree is installed. Use --jstree-path to set the path." - , "Download from http://github.com/downloads/vakata/jstree/jstree_pre1.0_fix_1.zip" - ] +main = simpleClckwrks clckwrksConfig hunk ./clckwrks-dot-com/Main.hs 37 -checkResource :: FilePath -> String -> IO () -checkResource fp msg = - do e <- doesFileExist fp - when (not e) $ putStrLn msg +initHook :: ClckState + -> ClckwrksConfig ClckURL + -> IO (ClckState, ClckwrksConfig ClckURL) +initHook clckState cc = + do let p = plugins clckState + initPlugin p "" clckPlugin + setTheme p (Just theme) + return (clckState, cc) hunk ./clckwrks-dot-com/PageMapper.hs 1 -module PageMapper where - -import Clckwrks -import qualified Theme.Page as Page -import qualified Theme.Home as Home - -pageMapper :: XMLGenT (Clck ClckURL) XML -pageMapper = - do pid <- XMLGenT $ getPageId - case pid of - (PageId 1) -> Home.page - _ -> Page.page rmfile ./clckwrks-dot-com/PageMapper.hs hunk ./clckwrks-dot-com/URL.hs 1 -{-# LANGUAGE TemplateHaskell #-} -module URL where - -import Clckwrks.URL (ClckURL) -import Clckwrks.Bugs (BugsURL) -import Clckwrks.Media (MediaURL) -import Web.Routes.TH (derivePathInfo) - -data SiteURL - = C ClckURL - | B BugsURL - | M MediaURL -$(derivePathInfo ''SiteURL) rmfile ./clckwrks-dot-com/URL.hs hunk ./clckwrks-dot-com/clckwrks-dot-com.cabal 1 -Name: clckwrks-dot-com -Version: 0.1.18 -Synopsis: clckwrks.com --- Description: -Homepage: http://clckwrks.com/ -License: BSD3 -License-file: LICENSE -Author: Jeremy Shaw -Maintainer: jeremy@n-heptane.com --- Copyright: -Category: Clckwrks -Build-type: Custom -Cabal-version: >=1.6 - -Flag plugins - Description: enable dynamic recompilation - Default: False - -Flag backups - Description: enable the backups executable (currently disabled by default do to wacky dependencies not on hackage) - Default: False - -Executable clckwrks-dot-com-server - Main-is: Main.hs - ghc-options: -threaded -O2 -rtsopts - cpp-options: -DCABAL - Extensions: CPP - Build-depends: - base < 5, - bytestring >= 0.9 && < 0.11, - clckwrks == 0.12.*, - clckwrks-plugin-bugs == 0.2.*, - clckwrks-plugin-media == 0.2.*, - containers >= 0.4 && < 0.6, - directory >= 1.1 && < 1.3, - filepath == 1.3.*, - happstack-server, - mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.5, - text == 0.11.*, - web-routes == 0.27.*, - web-routes-happstack == 0.23.*, - web-routes-th >= 0.21 - - if flag(plugins) - Build-depends: - plugins-auto > 0.0.1 - cpp-options: -DPLUGINS - else - Build-depends: - clckwrks-theme-clckwrks - -Executable clckwrks-dot-com-backups - Main-Is: Backups.hs - if flag(backups) - Buildable: True - GHC-Options: -threaded -Wall -Wwarn -O2 -fno-warn-name-shadowing -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-binds -fno-warn-orphans -fwarn-unused-imports -fno-spec-constr - Build-depends: archive >= 1.2.9, base, Extra - else - Buildable: False +name: clckwrks-dot-com +version: 0.2.0 +synopsis: clckwrks.com +homepage: http://www.clckwrks.com/ +license: BSD3 +license-file: LICENSE +author: Jeremy Shaw +maintainer: jeremy@n-heptane.com +category: Clckwrks +build-type: Simple +cabal-version: >=1.8 hunk ./clckwrks-dot-com/clckwrks-dot-com.cabal 13 +Executable clckwrks-dot-com-server + main-is: Main.hs + ghc-options: -threaded -O2 + build-depends: base > 4 && <5, + clckwrks == 0.13.*, + clckwrks-theme-clckwrks == 0.2.*, + containers == 0.4.*, + happstack-server >= 7.0 && < 7.2, + hsp == 0.7.*, + mtl >= 2.0 && < 2.2, + text == 0.11.*, + web-plugin == 0.1.* hunk ./clckwrks-dot-com/run.sh 1 -#!/bin/bash hunk ./clckwrks-dot-com/run.sh 2 -runhaskell -i../clckwrks/ -i../clckwrks-theme-clckwrks/ -i../clckwrks-plugin-media -i../clckwrks-plugin-bugs Main.hs --jstree-path=../jstree --json2-path=../json2 --jquery-path=../jquery --theme-path=../clckwrks-theme-clckwrks/ --bugs-data-path=../clckwrks-plugin-bugs/data "$1" "$2" "$3" "$4" rmfile ./clckwrks-dot-com/run.sh hunk ./clckwrks-theme-bootstrap/BootstrapTheme.hs 22 - + hunk ./clckwrks-theme-clckwrks/LICENSE 1 -Copyright (c)2011, Jeremy Shaw +Copyright (c) 2012, Jeremy Shaw addfile ./clckwrks-theme-clckwrks/Theme.hs hunk ./clckwrks-theme-clckwrks/Theme.hs 1 +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Theme where + +import Clckwrks +import Clckwrks.Monad +import Data.Text (Text) +import Happstack.Server +import HSP + +theme :: Theme +theme = Theme + { themeName = "bootstrap-theme" + , _themeTemplate = pageTemplate + } + +pageTemplate :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML +pageTemplate = + + + <% getPageTitle %> + + + + + + <% googleAnalytics %> + + + + +

<% getPageTitle %>

+ <% getPageContent %> +

+ + + hunk ./clckwrks-theme-clckwrks/clckwrks-theme-clckwrks.cabal 1 -Name: clckwrks-theme-clckwrks -Version: 0.1.24 -Synopsis: Theme for happstack.com --- Description: -Homepage: http://www.clckwrks.com/ -License: BSD3 -License-file: LICENSE -Author: Jeremy Shaw -Maintainer: jeremy@n-heptane.com --- Copyright: -Category: Clckwrks -Build-type: Custom -Cabal-version: >=1.2 -Data-Files: - data/style.css - data/hscolour.css - data/clckwrks-logo.png - data/7-icon.png - data/8-icon.png - data/philosophy-icon.png +name: clckwrks-theme-clckwrks +version: 0.2.0 +synopsis: simple bootstrap based template for clckwrks +homepage: http://www.clckwrks.com/ +license: BSD3 +license-file: LICENSE +author: Jeremy Shaw +maintainer: jeremy@n-heptane.com +category: Clckwrks +build-type: Simple +cabal-version: >=1.8 hunk ./clckwrks-theme-clckwrks/clckwrks-theme-clckwrks.cabal 13 -Library - Exposed-modules: Theme.Blog, - Theme.Home, - Theme.Page, - Theme.Template - Paths_clckwrks_theme_clckwrks - - Build-depends: - base < 5, - clckwrks == 0.12.*, - containers >= 0.4 && < 0.6, - happstack-hsp >= 7.1 && < 7.2, - text +library + exposed-modules: Theme + build-depends: base == 4.5.*, + clckwrks == 0.13.*, + happstack-server == 7.0.*, + hsp == 0.7.*, + text == 0.11.* hunk ./clckwrks/Clckwrks/Monad.hs 103 - hunk ./clckwrks/Clckwrks/Server.hs 87 + , nullDir >> seeOther ("/clck/view-page/1") (toResponse ()) hunk ./example-dot-org/Main.hs 43 -{- - (Just clckShowFn) <- getPluginRouteFn p "clck" - let showFn = \url params -> clckShowFn url [] - clckState' <- execClckT showFn clckState $ do dm <- defaultAdminMenu - mapM_ addAdminMenu dm --} -