[major refactoring to support new plugins architecture. kind of working. Jeremy Shaw **20121115211449 Ignore-this: d3f9e9d4cdc0f63561e7794afa97214f ] hunk ./clckwrks-dot-com/Main.hs 247 + adddir ./clckwrks-theme-bootstrap addfile ./clckwrks-theme-bootstrap/BootstrapTheme.hs hunk ./clckwrks-theme-bootstrap/BootstrapTheme.hs 1 +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module BootstrapTheme 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 %> + + + + + +

<% getPageTitle %>

+ <% getPageContent %> +

+ + + addfile ./clckwrks-theme-bootstrap/LICENSE hunk ./clckwrks-theme-bootstrap/LICENSE 1 +Copyright (c) 2012, 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. addfile ./clckwrks-theme-bootstrap/Setup.hs hunk ./clckwrks-theme-bootstrap/Setup.hs 1 +import Distribution.Simple +main = defaultMain addfile ./clckwrks-theme-bootstrap/clckwrks-theme-bootstrap.cabal hunk ./clckwrks-theme-bootstrap/clckwrks-theme-bootstrap.cabal 1 +name: clckwrks-theme-bootstrap +version: 0.1.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 + +library + exposed-modules: BootstrapTheme + build-depends: base == 4.5.*, + clckwrks == 0.13.*, + happstack-server == 7.0.*, + hsp == 0.7.*, + text == 0.11.* hunk ./clckwrks/Clckwrks/Admin/Route.hs 17 -routeAdmin :: Clck ClckURL Response -> AdminURL -> Clck ClckURL Response -routeAdmin pageHandler url = +routeAdmin :: AdminURL -> Clck ClckURL Response +routeAdmin url = hunk ./clckwrks/Clckwrks/Admin/Route.hs 25 - (PreviewPage pid) -> previewPage pageHandler pid +-- (PreviewPage pid) -> previewPage pageHandler pid -- FIXME hunk ./clckwrks/Clckwrks/Monad.hs 10 + , Theme(..) + , ThemeName hunk ./clckwrks/Clckwrks/Monad.hs 21 - , addPreProcessor +-- , addPreProcessor hunk ./clckwrks/Clckwrks/Monad.hs 93 +import Web.Plugin.Core (Plugins) hunk ./clckwrks/Clckwrks/Monad.hs 98 +type ThemeName = T.Text + +data Theme = Theme + { themeName :: ThemeName + , _themeTemplate :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML + +{- + , _themeTemplate :: ( EmbedAsChild (ServerPartT IO) headers + , EmbedAsChild (ServerPartT IO) body) => + T.Text -- ^ page title + -> headers -- ^ extra elements to add to \ + -> body -- ^ elements to insert in \ + -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML +-} + } + hunk ./clckwrks/Clckwrks/Monad.hs 121 - , preProcessorCmds :: forall m url. (Functor m, MonadIO m, Happstack m) => Map T.Text (T.Text -> ClckT url m Builder) -- TODO: should this be a TVar? +-- , preProcessorCmds :: forall m url. (Functor m, MonadIO m, Happstack m) => Map T.Text (T.Text -> ClckT url m Builder) -- TODO: should this be a TVar? hunk ./clckwrks/Clckwrks/Monad.hs 124 + , plugins :: Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) hunk ./clckwrks/Clckwrks/Monad.hs 211 - +{- hunk ./clckwrks/Clckwrks/Monad.hs 216 - +-} hunk ./clckwrks/Clckwrks/Monad.hs 470 - markup' <- process (preProcessorCmds clckState) markup + markup' <- return markup -- process (preProcessorCmds clckState) markup addfile ./clckwrks/Clckwrks/Plugin.hs hunk ./clckwrks/Clckwrks/Plugin.hs 1 +{-# LANGUAGE RecordWildCards, FlexibleContexts, OverloadedStrings #-} +module Clckwrks.Plugin where + +import Control.Applicative ((<$>)) +import Control.Monad.State (MonadState(get)) +import Clckwrks +import Clckwrks.Acid +import Clckwrks.Admin.Route (routeAdmin) +import Clckwrks.Admin.Template (defaultAdminMenu) +import Clckwrks.BasicTemplate (basicTemplate) +import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..)) +import Clckwrks.Page.Atom (handleAtomFeed) +import Clckwrks.ProfileData.Route (routeProfileData) +import Clckwrks.Monad +import Clckwrks.URL +import Clckwrks.Server (checkAuth) +import Control.Monad +import Control.Monad.Trans +import Data.Text (Text) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Happstack.Server +import Happstack.Auth (handleAuthProfile) +import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile) +import Network.URI (unEscapeString) +import System.FilePath ((), makeRelative, splitDirectories) +import Web.Routes hiding (nestURL) +import Web.Plugin.Core +{- +themeTemplate :: ( EmbedAsChild (ServerPartT IO) headers + , EmbedAsChild (ServerPartT IO) body + ) => + Plugins Theme (ClckT ClckURL (ServerPartT IO) XML) + -> Text + -> headers + -> body + -> ClckT ClckURL (ServerPartT IO) Response +themeTemplate plugins title headers body = + do mTheme <- getTheme plugins + case mTheme of + Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: Text) + (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme) title headers body +-} + +themeTemplate plugins = + do mTheme <- getTheme plugins + case mTheme of + Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: Text) + (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme) + + +clckHandler :: (ClckURL -> [(Text, Text)] -> Text) + -> Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) + -> [Text] + -> ClckT ClckURL (ServerPartT IO) Response +clckHandler showRouteFn plugins paths = + case parseSegments fromPathSegments paths of + (Left e) -> notFound $ toResponse (show e) + (Right u) -> routeClck u +{- + (Right (ViewPage _)) -> + do pps <- liftIO $ getPreProcs plugins + txt <- liftIO $ foldM (\txt pp -> pp txt) "I like cheese." (Map.elems pps) +-- themeTemplate plugins "cheese." ()

<% txt %>

+ ok $ toResponse txt +-} + +routeClck :: ClckURL -> Clck ClckURL Response +routeClck url' = + do url <- checkAuth url' + setUnique 0 + case url of + (ViewPage pid) -> + do r <- query (GetPageTitle pid) + case r of + Nothing -> + notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid)) + (Just (title, slug)) -> + seeOtherURL (ViewPageSlug pid (toSlug title slug)) + + (ViewPageSlug pid _slug) -> + do published <- query (IsPublishedPage pid) + if published + then do setCurrentPage pid + cs <- get + themeTemplate (plugins cs) +-- ok $ toResponse (show pid) +-- (clckPageHandler cc) + else do notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid)) +{- + (Blog) -> + do clckBlogHandler cc +-} + AtomFeed -> + do handleAtomFeed + + (ThemeData fp') -> + do fp <- themePath <$> get + let fp'' = makeRelative "/" (unEscapeString fp') + if not (isSafePath (splitDirectories fp'')) + then notFound (toResponse ()) + else serveFile (guessContentTypeM mimeTypes) (fp "data" fp'') + + (PluginData plugin fp') -> + do ppm <- pluginPath <$> get + case Map.lookup plugin ppm of + Nothing -> notFound (toResponse ()) + (Just pp) -> + do let fp'' = makeRelative "/" (unEscapeString fp') + if not (isSafePath (splitDirectories fp'')) + then notFound (toResponse ()) + else serveFile (guessContentTypeM mimeTypes) (pp "data" fp'') + + (Admin adminURL) -> + routeAdmin adminURL + + (Profile profileDataURL) -> + do nestURL Profile $ routeProfileData profileDataURL + + (Auth apURL) -> + do Acid{..} <- acidState <$> get + u <- showURL $ Profile CreateNewProfileData + nestURL Auth $ handleAuthProfile acidAuth acidProfile basicTemplate Nothing Nothing u apURL + +clckInit :: Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) -> IO (Maybe Text) +clckInit plugins = + do (Just clckShowFn) <- getPluginRouteFn plugins "clck" +-- evalClckT defaultAdminMenu clckShowFn +-- addPreProc plugins "clck" (clckPreProcessor clckShowFn) + addHandler plugins "clck" (clckHandler clckShowFn) + return Nothing + + +clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) +clckPlugin = Plugin + { pluginName = "clck" + , pluginInit = clckInit + , pluginDepends = [] + , pluginToPathInfo = toPathInfo + , pluginPostHook = return () + } + +plugin :: Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) -> Text -> IO (Maybe Text) +plugin plugins baseURI = + initPlugin plugins baseURI clckPlugin hunk ./clckwrks/Clckwrks/Server.hs 1 -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-} hunk ./clckwrks/Clckwrks/Server.hs 7 +import Clckwrks.Admin.Template (defaultAdminMenu) hunk ./clckwrks/Clckwrks/Server.hs 14 +import Control.Arrow (second) hunk ./clckwrks/Clckwrks/Server.hs 19 +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) hunk ./clckwrks/Clckwrks/Server.hs 31 +import Web.Plugin.Core (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve) hunk ./clckwrks/Clckwrks/Server.hs 44 - , clckPageHandler :: Clck ClckURL Response - , clckBlogHandler :: Clck ClckURL Response +-- , clckPageHandler :: Clck ClckURL Response +-- , clckBlogHandler :: Clck ClckURL Response hunk ./clckwrks/Clckwrks/Server.hs 48 + , clckInitHook :: ClckState -> ClckwrksConfig url -> IO (ClckState, ClckwrksConfig url) hunk ./clckwrks/Clckwrks/Server.hs 53 - do withAcid (fmap (\top -> top "_state") (clckTopDir cc)) $ \acid -> + withPlugins $ \plugins -> + withAcid (fmap (\top -> top "_state") (clckTopDir cc)) $ \acid -> hunk ./clckwrks/Clckwrks/Server.hs 62 - , preProcessorCmds = Map.empty +-- , preProcessorCmds = Map.empty hunk ./clckwrks/Clckwrks/Server.hs 65 + , plugins = plugins hunk ./clckwrks/Clckwrks/Server.hs 72 - simpleHTTP (nullConf { port = clckPort cc }) (handlers cc clckState) + do (clckState', cc') <- (clckInitHook cc) clckState cc + let p = plugins clckState' + hooks <- getPostHooks p + (Just clckShowFn) <- getPluginRouteFn p "clck" + let showFn = \url params -> clckShowFn url [] + clckState'' <- execClckT showFn clckState' $ do dm <- defaultAdminMenu + mapM_ addAdminMenu dm + simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') hunk ./clckwrks/Clckwrks/Server.hs 87 - , implSite (Text.pack $ "http://" ++ clckHostname cc ++ ":" ++ show (clckPort cc)) (Text.pack "") (clckSite cc clckState) + , clckSite cc clckState +-- , implSite (Text.pack $ "http://" ++ clckHostname cc ++ ":" ++ show (clckPort cc)) (Text.pack "") (clckSite cc clckState) hunk ./clckwrks/Clckwrks/Server.hs 113 - +{- hunk ./clckwrks/Clckwrks/Server.hs 131 - (clckPageHandler cc) + clckState <- get + (pageHandler clckState) hunk ./clckwrks/Clckwrks/Server.hs 134 - (Blog) -> - do clckBlogHandler cc +-- (Blog) -> +-- do pageHandler cc hunk ./clckwrks/Clckwrks/Server.hs 154 - routeAdmin (clckPageHandler cc) adminURL + do clckState <- get + routeAdmin (pageHandler clckState) adminURL hunk ./clckwrks/Clckwrks/Server.hs 166 +-} +clckSite :: ClckwrksConfig u -> ClckState -> ServerPart Response +clckSite cc clckState = + do (Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck") + evalClckT (\u p -> clckShowFn u (map (second fromJust) p)) clckState (pluginsHandler (plugins clckState)) + + +pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) => + Plugins theme (m Response) hook + -> m Response +pluginsHandler plugins = + do paths <- (map Text.pack . rqPaths) <$> askRq + case paths of + (p : ps) -> + do e <- liftIO $ serve plugins p ps + case e of + (Right c) -> c + (Left e) -> notFound $ toResponse e + _ -> notFound (toResponse ()) + + hunk ./clckwrks/Clckwrks/Server.hs 188 +-- where +-- showFn u p = (Text.pack $ "http://" ++ clckHostname cc ++ ":" ++ show (clckPort cc)) <> toPathInfoParams u p +{- hunk ./clckwrks/Clckwrks/Server.hs 195 +-} +{- +pageHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) => + Plugins theme (m Response) -> m Response +pageHandler plugins = + do paths <- (map Text.pack . rqPaths) <$> askRq + case paths of + (p : ps) -> + do e <- liftIO $ serve plugins p ps + case e of + (Right c) -> c + (Left e) -> notFound $ toResponse e + _ -> notFound (toResponse ()) +-} hunk ./clckwrks/clckwrks.cabal 2 -Version: 0.12.3 +Version: 0.13.0 hunk ./clckwrks/clckwrks.cabal 48 + Clckwrks.Plugin hunk ./clckwrks/clckwrks.cabal 98 + web-plugin, adddir ./example-dot-org addfile ./example-dot-org/LICENSE hunk ./example-dot-org/LICENSE 1 +Copyright (c) 2012, 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. addfile ./example-dot-org/Main.hs hunk ./example-dot-org/Main.hs 1 +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Main where + +import Clckwrks.URL +import Clckwrks.Admin.Template +import Clckwrks.Monad +import Clckwrks.Server +import Clckwrks.Plugin +import Control.Applicative ((<$>)) +import Control.Monad.Trans +import BootstrapTheme +import qualified Data.Map as Map +import qualified Data.Text as Text +import Happstack.Server +import Web.Plugin.Core + +clckwrksConfig :: ClckwrksConfig ClckURL +clckwrksConfig = ClckwrksConfig + { clckHostname = "localhost" + , clckPort = 8000 + , clckURL = id + , clckJQueryPath = "" + , clckJQueryUIPath = "" + , clckJSTreePath = "" + , clckJSON2Path = "" + , clckThemeDir = "" + , clckPluginDir = Map.empty + , clckStaticDir = "../clckwrks/static" + , clckTopDir = Nothing + , clckEnableAnalytics = False + , clckInitHook = initHook + } + +main :: IO () +main = simpleClckwrks clckwrksConfig + +initHook :: ClckState + -> ClckwrksConfig ClckURL + -> IO (ClckState, ClckwrksConfig ClckURL) +initHook clckState cc = + do let p = plugins clckState + initPlugin p "" clckPlugin +{- + (Just clckShowFn) <- getPluginRouteFn p "clck" + let showFn = \url params -> clckShowFn url [] + clckState' <- execClckT showFn clckState $ do dm <- defaultAdminMenu + mapM_ addAdminMenu dm +-} + + setTheme p (Just theme) + return (clckState, cc) addfile ./example-dot-org/Setup.hs hunk ./example-dot-org/Setup.hs 1 +import Distribution.Simple +main = defaultMain addfile ./example-dot-org/example-dot-org.cabal hunk ./example-dot-org/example-dot-org.cabal 1 +name: example-dot-org +version: 0.1.0.0 +synopsis: an example clckwrks site +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 + +Executable example-dot-org-server + main-is: Main.hs + ghc-options: -threaded -O2 + build-depends: base > 4 && <5, + clckwrks == 0.13.*, + clckwrks-theme-bootstrap == 0.1.*, + containers == 0.4.*, + happstack-server >= 7.0 && < 7.2, + hsp == 0.7.*, + mtl >= 2.0 && < 2.2, + text == 0.11.*, + web-plugin == 0.1.*