clckwrks (empty) → 0.13.0
raw patch · 44 files changed
+3728/−0 lines, 44 filesdep +acid-statedep +aesondep +attoparsecbuild-type:Customsetup-changed
Dependencies added: acid-state, aeson, attoparsec, base, blaze-html, bytestring, containers, directory, filepath, happstack-authenticate, happstack-hsp, happstack-server, hsp, hsx, hsx-jmacro, ixset, jmacro, mtl, network, old-locale, process, random, reform, reform-happstack, reform-hsp, safecopy, stm, tagsoup, text, time, unordered-containers, utf8-string, uuid, vector, web-plugins, web-routes, web-routes-happstack, web-routes-hsp, web-routes-th, xss-sanitize
Files
- Clckwrks.hs +47/−0
- Clckwrks/Acid.hs +50/−0
- Clckwrks/Admin/Console.hs +14/−0
- Clckwrks/Admin/EditFeedConfig.hs +41/−0
- Clckwrks/Admin/EditPage.hs +90/−0
- Clckwrks/Admin/EditSettings.hs +39/−0
- Clckwrks/Admin/NewPage.hs +33/−0
- Clckwrks/Admin/Pages.hs +29/−0
- Clckwrks/Admin/PreviewPage.hs +29/−0
- Clckwrks/Admin/Route.hs +32/−0
- Clckwrks/Admin/Template.hs +101/−0
- Clckwrks/Admin/URL.hs +23/−0
- Clckwrks/BasicTemplate.hs +32/−0
- Clckwrks/GetOpts.hs +73/−0
- Clckwrks/IOThread.hs +48/−0
- Clckwrks/Markup/HsColour.hs +41/−0
- Clckwrks/Markup/Markdown.hs +43/−0
- Clckwrks/Menu/API.hs +48/−0
- Clckwrks/Menu/Acid.hs +45/−0
- Clckwrks/Menu/Edit.hs +330/−0
- Clckwrks/Menu/Types.hs +101/−0
- Clckwrks/Monad.hs +564/−0
- Clckwrks/Page/API.hs +129/−0
- Clckwrks/Page/Acid.hs +207/−0
- Clckwrks/Page/Atom.hs +90/−0
- Clckwrks/Page/PreProcess.hs +70/−0
- Clckwrks/Page/Types.hs +199/−0
- Clckwrks/Plugin.hs +131/−0
- Clckwrks/ProfileData/API.hs +28/−0
- Clckwrks/ProfileData/Acid.hs +169/−0
- Clckwrks/ProfileData/EditProfileData.hs +56/−0
- Clckwrks/ProfileData/EditProfileDataFor.hs +57/−0
- Clckwrks/ProfileData/Route.hs +31/−0
- Clckwrks/ProfileData/Types.hs +68/−0
- Clckwrks/ProfileData/URL.hs +16/−0
- Clckwrks/Server.hs +111/−0
- Clckwrks/Types.hs +17/−0
- Clckwrks/URL.hs +68/−0
- Clckwrks/Unauthorized.hs +31/−0
- HSP/HTMLBuilder.hs +156/−0
- LICENSE +30/−0
- Setup.hs +13/−0
- clckwrks.cabal +119/−0
- static/admin.css +79/−0
+ Clckwrks.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-}+module Clckwrks+ ( module Clckwrks.Acid+ , module Clckwrks.Menu.API+ , module Clckwrks.Monad+ , module Clckwrks.Page.API+ , module Clckwrks.Page.Types+ , module Clckwrks.ProfileData.API+ , module Clckwrks.ProfileData.Types+ , module Clckwrks.Types+ , module Clckwrks.Unauthorized+ , module Clckwrks.URL+ , module Control.Applicative+ , module Control.Monad+ , module Control.Monad.Trans+ , module Happstack.Auth+ , module HSP+ , module HSP.ServerPartT+ , module Happstack.Server+ , module Language.Javascript.JMacro+ , module Web.Routes+ , module Web.Routes.Happstack+ ) where++import Clckwrks.Acid+import Clckwrks.Admin.URL+import Clckwrks.Menu.API+import Clckwrks.Monad+import Clckwrks.Page.API+import Clckwrks.Page.Types+import Clckwrks.ProfileData.API+import Clckwrks.ProfileData.Types+import Clckwrks.Types+import Clckwrks.Unauthorized+import Clckwrks.URL+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Happstack.Auth (UserId(..))+import Happstack.Server+import Happstack.Server.HSP.HTML+import HSP hiding (Request, escape)+import HSP.ServerPartT+import Language.Javascript.JMacro (JExpr(..), JMacro(..), JStat(..), JType(..), JVal(..), Ident(..), toJExpr, jmacro, jmacroE)+import Web.Routes hiding (nestURL)+import Web.Routes.XMLGenT ()+import Web.Routes.Happstack (seeOtherURL)
+ Clckwrks/Acid.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+module Clckwrks.Acid where++import Clckwrks.Menu.Acid (MenuState , initialMenuState)+import Clckwrks.Page.Acid (PageState , initialPageState)+import Clckwrks.ProfileData.Acid (ProfileDataState, initialProfileDataState)+import Clckwrks.URL (ClckURL)+import Control.Exception (bracket, catch, throw)+import Control.Concurrent (killThread, forkIO)+import Data.Acid (AcidState)+import Data.Acid.Local (openLocalStateFrom, createArchive, createCheckpointAndClose)+import Data.Acid.Remote (acidServer)+import Data.Maybe (fromMaybe)+import Happstack.Auth.Core.Auth (AuthState , initialAuthState)+import Happstack.Auth.Core.Profile (ProfileState , initialProfileState)+import Network (PortID(UnixSocket))+import Prelude hiding (catch)+import System.Directory (removeFile)+import System.FilePath ((</>))+import System.IO.Error (isDoesNotExistError)++data Acid = Acid+ { acidAuth :: AcidState AuthState+ , acidProfile :: AcidState ProfileState+ , acidProfileData :: AcidState ProfileDataState+ , acidPage :: AcidState PageState+ , acidMenu :: AcidState (MenuState ClckURL)+ }++class GetAcidState m st where+ getAcidState :: m (AcidState st)++withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a+withAcid mBasePath f =+ let basePath = fromMaybe "_state" mBasePath in+ initialPageState >>= \ips ->+ bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) (createArchiveCheckpointAndClose) $ \auth ->+ bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createArchiveCheckpointAndClose) $ \profile ->+ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData ->+ bracket (openLocalStateFrom (basePath </> "page") ips) (createArchiveCheckpointAndClose) $ \page ->+ bracket (openLocalStateFrom (basePath </> "menu") initialMenuState) (createArchiveCheckpointAndClose) $ \menu ->+ bracket (forkIO $ tryRemoveFile (basePath </> "profileData_socket") >> acidServer profileData (UnixSocket $ basePath </> "profileData_socket"))+ (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket"))+ (const $ f (Acid auth profile profileData page menu))+ where+ tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e)+ createArchiveCheckpointAndClose acid =+ do createArchive acid+ createCheckpointAndClose acid+
+ Clckwrks/Admin/Console.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.Console where++import Clckwrks (AdminURL(..), Clck, Response)+import Clckwrks.Admin.Template (template)+import HSP++consolePage :: Clck AdminURL Response+consolePage =+ do template "Administration" () $+ <div>+ <p>Enter a world of excitement.</p>+ </div>+
+ Clckwrks/Admin/EditFeedConfig.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.EditFeedConfig where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Acid (GetFeedConfig(..), SetFeedConfig(..))+import Data.Text (Text, pack)+import Text.Reform+import Text.Reform.Happstack+import Text.Reform.HSP.Text++editFeedConfig :: ClckURL -> Clck ClckURL Response+editFeedConfig here =+ do feedConfig <- query $ GetFeedConfig+ action <- showURL here+ template "edit feed config" () $+ <%>+ <% reform (form action) "ep" updateFeedConfig Nothing (feedConfigForm feedConfig) %>+ </%>+ where+ updateFeedConfig :: FeedConfig -> Clck ClckURL Response+ updateFeedConfig fc =+ do update (SetFeedConfig fc)+ seeOtherURL (Admin Console)++feedConfigForm :: FeedConfig -> ClckForm ClckURL FeedConfig+feedConfigForm fc@FeedConfig{..} =+ fieldset $+ ol $+ ((,) <$> (li $ label "Feed Title:") ++> (li $ inputText feedTitle)+ <*> (li $ label "Default Author Name:") ++> (li $ inputText feedAuthorName)+ <* inputSubmit (pack "update")+ )+ `transformEither` toFeedConfig+ where+ toFeedConfig :: (Text, Text) -> Either ClckFormError FeedConfig+ toFeedConfig (ttl, athr) =+ Right $ fc { feedTitle = ttl+ , feedAuthorName = athr+ }
+ Clckwrks/Admin/EditPage.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.EditPage+ ( editPage+ ) where++import Control.Applicative ((<$>), (<*>), (<*))+import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.Monad (ClckFormError)+import Clckwrks.Page.Acid (Markup(..), Page(..), PageKind(..), PublishStatus(..), PreProcessor(..), PageById(..), UpdatePage(..))+import Data.Maybe (isJust, maybe)+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Data.Time.Clock (getCurrentTime)+import Text.Reform ((<++), (++>), transformEitherM)+import Text.Reform.Happstack (reform)+import Text.Reform.HSP.Text (form, inputCheckbox, inputText, label, inputSubmit, select, textarea, fieldset, ol, li, setAttrs)++data AfterSaveAction+ = EditSomeMore+ | VisitPage+ | ShowPreview++editPage :: ClckURL -> PageId -> Clck ClckURL Response+editPage here pid =+ do mPage <- query $ PageById pid+ case mPage of+ Nothing -> notFound $ toResponse $ "Page not found: " ++ show (unPageId pid)+ (Just page) ->+ do action <- showURL here+ template "edit page" () $+ <%>+ <% reform (form action) "ep" updatePage Nothing (pageFormlet page) %>+ </%>+ where+ updatePage :: (Page, AfterSaveAction) -> Clck ClckURL Response+ updatePage (page, afterSaveAction) =+ do update (UpdatePage page)+ case afterSaveAction of+ EditSomeMore -> seeOtherURL (Admin $ EditPage (pageId page))+ VisitPage -> seeOtherURL (ViewPageSlug (pageId page) (toSlug (pageTitle page) (pageSlug page)))+ ShowPreview -> seeOtherURL (Admin $ PreviewPage (pageId page))+++pageFormlet :: Page -> ClckForm ClckURL (Page, AfterSaveAction)+pageFormlet page =+ (fieldset $+ ol $ (,,,,,,,)+ <$> (li $ inputCheckbox hsColour <++ label "Highlight Haskell code with HsColour")+ <*> ((li $ label "kind:") ++> (li $ select [(PlainPage, "page"), (Post, "post")] (== (pageKind page))))+ <*> ((li $ label "title:") ++> (li $ inputText (pageTitle page) `setAttrs` ("size" := "80") ))+ <*> ((li $ label "slug (optional):") ++> (li $ inputText (maybe Text.empty unSlug $ pageSlug page) `setAttrs` ("size" := "80") ))+ <*> ((li $ label "body:") ++> (li $ textarea 80 25 (markup (pageSrc page))))+ <*> inputSubmit (pack "save")+ <*> inputSubmit (pack "preview")+ <*> newPublishStatus (pageStatus page)+ ) `transformEitherM` toPage+ where+ newPublishStatus :: PublishStatus -> ClckForm ClckURL (Maybe PublishStatus)+ newPublishStatus Published = fmap (const Draft) <$> inputSubmit (pack "save & unpublish")+ newPublishStatus _ = fmap (const Published) <$> inputSubmit (pack "save & publish")+ hsColour = HsColour `elem` (preProcessors $ pageSrc page)+ toPage :: (MonadIO m) => (Bool, PageKind, Text, Text, Text, Maybe Text, Maybe Text, Maybe PublishStatus) -> m (Either ClckFormError (Page, AfterSaveAction))+ toPage (haskell, kind, ttl, slug, bdy, msave, mpreview, mpagestatus) =+ do now <- liftIO $ getCurrentTime+ return $ Right $+ ( Page { pageId = pageId page+ , pageAuthor = pageAuthor page+ , pageTitle = ttl+ , pageSlug = if Text.null slug then Nothing else Just (slugify slug)+ , pageSrc = Markup { preProcessors = (if haskell then ([ HsColour ] ++) else id) [ Markdown ]+ , trust = Trusted+ , markup = bdy+ }+ , pageExcerpt = Nothing+ , pageDate = pageDate page+ , pageUpdated = now+ , pageStatus = case mpagestatus of+ (Just newStatus) -> newStatus+ Nothing -> pageStatus page+ , pageKind = kind+ , pageUUID = pageUUID page+ }+ , if isJust mpreview+ then ShowPreview+ else case mpagestatus of+ (Just Published) -> VisitPage+ _ -> EditSomeMore+ )
+ Clckwrks/Admin/EditSettings.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.EditSettings where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..))+import HSP.Google.Analytics (UACCT(..))+import Text.Reform+import Text.Reform.Happstack+import Text.Reform.HSP.String++editSettings :: ClckURL -> Clck ClckURL Response+editSettings here =+ do muacct <- query $ GetUACCT+ action <- showURL here+ template "Edit Settings" () $+ <%>+ <% reform (form action) "ss" updateSettings Nothing (editSettingsForm muacct) %>+ </%>+ where+ updateSettings :: Maybe UACCT -> Clck ClckURL Response+ updateSettings muacct =+ do update (SetUACCT muacct)+ seeOtherURL (Admin Console)++editSettingsForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT)+editSettingsForm muacct =+ fieldset $+ ol $+ ((li $ label "Google Analytics UACCT:") ++> (li $ (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*+ inputSubmit "update"+ where+ unUACCT (Just (UACCT str)) = str+ unUACCT Nothing = ""++ toMUACCT :: String -> Either ClckFormError (Maybe UACCT)+ toMUACCT [] = Right $ Nothing+ toMUACCT str = Right $ Just (UACCT str)
+ Clckwrks/Admin/NewPage.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.NewPage where++import Clckwrks+import Clckwrks.Page.Acid as Acid+import Clckwrks.Admin.Template (template)+import Data.UUID () -- instance Random UUID+import Data.Time.Clock (getCurrentTime)+import System.Random (randomIO)++newPage :: PageKind -> Clck AdminURL Response+newPage pageKind =+ do method GET+ template "Create New Page/Post" () $+ <%>+ <form action=Clckwrks.NewPage method="POST" enctype="multipart/form-data">+ <button type="submit">Create New Page</button>+ </form>+ <form action=Clckwrks.NewPost method="POST" enctype="multipart/form-data">+ <button type="submit">Create New Post</button>+ </form>+ </%>++ <|>+ do method POST+ uuid <- liftIO $ randomIO+ now <- liftIO $ getCurrentTime+ muid <- getUserId+ case muid of+ Nothing -> escape $ internalServerError $ toResponse "Clcwrks.Admin.NewPage.newPage was unable to obtain the current UserId"+ (Just uid) ->+ do page <- update (Acid.NewPage pageKind uid uuid now)+ seeOtherURL (EditPage (pageId page))
+ Clckwrks/Admin/Pages.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.Pages where++import Clckwrks (AdminURL(..), Clck, ClckURL(..), PageId(..), Response, query)+import Clckwrks.Admin.URL (AdminURL(..))+import Clckwrks.Admin.Template (template)+import Clckwrks.Page.Acid (PagesSummary(..))+import Clckwrks.Page.Types (Slug(..))+import Data.Text (Text)+import HSP++pages :: Clck AdminURL Response+pages =+ do pages <- query PagesSummary+ template "page list" () $ editList pages++editList :: [(PageId, Text, Maybe Slug)] -> GenChildList (Clck AdminURL)+editList [] = <%><p>There are currently no pages.</p></%>+editList pgs =+ <%>+ <p>Edit Page</p>+ <ul class="plain-list">+ <% mapM editPageLI pgs %>+ </ul>+ </%>+ where+ editPageLI :: (PageId, Text, Maybe Slug) -> GenXML (Clck AdminURL)+ editPageLI (pid, ttl, _slug) =+ <li><a href=(EditPage pid)><% ttl %></a></li>
+ Clckwrks/Admin/PreviewPage.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.PreviewPage+ ( previewPage+ ) where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.ProfileData.Acid (HasRole(..))+import Clckwrks.Page.Acid (Page(..), PublishStatus(..), PageById(..))+import Clckwrks.Unauthorized ()+import qualified Data.Set as Set++previewPage :: Clck ClckURL Response -> PageId -> Clck ClckURL Response+previewPage pageHandler pid =+ do mPage <- query $ PageById pid+ case mPage of+ Nothing -> do notFound ()+ template "Page not found" () $ <% "Page not found: " ++ show (unPageId pid) %>+ (Just page) ->+ do muid <- getUserId+ authorized <-+ case muid of+ Nothing -> return False+ (Just uid) -> query $ HasRole uid (Set.singleton Administrator)+ if authorized+ then do setCurrentPage pid+ pageHandler+ else unauthorized (toResponse $ "Sorry, you need Administrator access to view this page.")
+ Clckwrks/Admin/Route.hs view
@@ -0,0 +1,32 @@+module Clckwrks.Admin.Route where++import Clckwrks+import Clckwrks.Admin.Console+import Clckwrks.Admin.URL+import Clckwrks.Admin.EditFeedConfig (editFeedConfig)+import Clckwrks.Admin.EditPage (editPage)+import Clckwrks.Admin.EditSettings (editSettings)+import Clckwrks.Admin.NewPage (newPage)+import Clckwrks.Admin.PreviewPage (previewPage)+import Clckwrks.Admin.Pages+import Clckwrks.Menu.Acid+import Clckwrks.Menu.Edit+import Clckwrks.Menu.Types++-- | routes for 'AdminURL'+routeAdmin :: AdminURL -> Clck ClckURL Response+routeAdmin url =+ case url of+ Console -> nestURL Admin $ consolePage+ (EditPage pid) -> editPage (Admin url) pid+ EditFeedConfig -> editFeedConfig (Admin url)+ EditSettings -> editSettings (Admin url)+ NewPage -> nestURL Admin $ newPage PlainPage+-- (PreviewPage pid) -> previewPage pageHandler pid -- FIXME+ NewPost -> nestURL Admin $ newPage Post+ Pages -> nestURL Admin $ pages+ EditMenu ->+ do menu <- query AskMenu+ editMenu (menu :: Menu ClckURL)+ MenuPOST -> menuPost+
+ Clckwrks/Admin/Template.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Admin.Template where++import Clckwrks hiding (mapM, sequence)+import Control.Arrow (second)+import Control.Monad.State (get)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as T+import Control.Monad.Instances+import Prelude hiding (mapM, sequence)++import Data.Monoid+import Data.Foldable+import Data.Traversable++template ::+ ( Functor m+ , Monad m+ , EmbedAsChild (ClckT url m) headers+ , EmbedAsChild (ClckT url m) body+ ) => String -> headers -> body -> ClckT url m Response+template title headers body =+ toResponse <$> (unXMLGenT $+ <html>+ <head>+ <link type="text/css" href="/static/admin.css" rel="stylesheet" />+ <script type="text/javascript" src="/jquery/jquery.js" ></script>+ <script type="text/javascript" src="/json2/json2.js" ></script>+ <title><% title %></title>+ <% headers %>+ </head>+ <body>+ <% sidebar %>+ <div id="admin-body">+ <% body %>+ </div>+ </body>+ </html>)++m :: (Monad m) => (b -> m c) -> (a, b) -> m (a, c)+m f x = l $ second f x++l :: (Monad m) => (a, m b) -> m (a, b)+l (a, m) =+ do b <- m+ return (a ,b)++instance (Monoid a) => Monad ((,) a) where+ return b = (mempty, b)+ (a, b) >>= f = let (a', b') = f b in (a `mappend` a', b')++instance Foldable ((,) a) where+ fold = snd+ foldMap f (b, a) = f a++instance Traversable ((,) a) where+ traverse f (c, a) = fmap (\b -> (c, b)) $ f a+ sequenceA (c, fa) = fmap (\a -> (c, a)) fa+ mapM f (c, a) =+ do b <- f a+ return (c, b)+ sequence (a, m) = do b <- m+ return (a, b)++defaultAdminMenu :: (Monad m) => ClckT ClckURL m [(Text, [(Text, Text)])]+defaultAdminMenu =+ do links <- sequence $ map sequence $ map (second (showURL . Admin))+ [ (fromString "Console" , Console)+ , (fromString "Edit Settings" , EditSettings)+ , (fromString "Edit Feed Config", EditFeedConfig)+ , (fromString "Edit Page/Post" , Pages)+ , (fromString "New Page/Post" , NewPage)+ , (fromString "Edit Menu" , EditMenu)+ ]+ return [(fromString "Admin", links)]++sidebar :: (Functor m, Monad m) => XMLGenT (ClckT url m) XML+sidebar =+ <div id="admin-sidebar">+ <% adminMenuXML %>+ </div>++adminMenuXML :: (Functor m, Monad m) => XMLGenT (ClckT url m) XML+adminMenuXML =+ do menu <- adminMenus <$> get+ <ul id="admin-menu">+ <% mapM mkMenu menu %>+ </ul>+ where+ mkMenu :: (Functor m, Monad m) => (T.Text, [(T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML+ mkMenu (category, links) =+ <li class="admin-menu-category"><span class="admin-menu-category-title"><% category %></span>+ <ul id="admin-menu-links">+ <% mapM mkLink links %>+ </ul>+ </li>+ mkLink :: (Functor m, Monad m) => (T.Text, T.Text) -> XMLGenT (ClckT url m) XML+ mkLink (title, url) =+ <li class="admin-menu-link"><a href=url><% title %></a></li>
+ Clckwrks/Admin/URL.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}+module Clckwrks.Admin.URL where++import Clckwrks.Page.Types (PageId(..))+import Data.Data (Data, Typeable)+import Data.SafeCopy (base, deriveSafeCopy)+import Web.Routes.TH (derivePathInfo)++data AdminURL+ = Console+ | EditPage PageId+ | PreviewPage PageId+ | EditFeedConfig+ | EditSettings+ | Pages+ | NewPage+ | NewPost+ | EditMenu+ | MenuPOST+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(derivePathInfo ''AdminURL)+$(deriveSafeCopy 1 'base ''AdminURL)
+ Clckwrks/BasicTemplate.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.BasicTemplate (basicTemplate) where++import Control.Applicative ((<$>))+import Clckwrks.Monad+import Happstack.Server (Response, toResponse)+import Happstack.Server.HSP.HTML ()+import HSP++basicTemplate :: + ( Functor m+ , Monad m+ , EmbedAsChild (ClckT url m) headers+ , EmbedAsChild (ClckT url m) body+ ) => String -> headers -> body -> ClckT url m Response+basicTemplate title headers body =+ toResponse <$> (unXMLGenT $+ <html>+ <head>+ <link type="text/css" href="/static/style.css" rel="stylesheet" />+ <script type="text/javascript" src="/jquery/jquery.js" ></script>+ <script type="text/javascript" src="/json2/json2.js" ></script>+ <title><% title %></title>+ <% headers %>+ </head>+ <body>+ <div id="body">+ <% body %>+ </div>+ </body>+ </html>)
+ Clckwrks/GetOpts.hs view
@@ -0,0 +1,73 @@+module Clckwrks.GetOpts where++import Clckwrks.Monad+import System.Console.GetOpt -- (Permute, OptDescr, getOpt)+import System.Environment+import System.Exit+++------------------------------------------------------------------------------+-- Command line options+------------------------------------------------------------------------------++-- | command-line Flags+data Flag+ = ModifyConfig (ClckwrksConfig -> ClckwrksConfig)+ | 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 -> [OptDescr Flag]+clckwrksOpts def =+ [ Option [] ["help"] (NoArg Help) "Display this help message"+ , Option [] ["http-port"] (ReqArg setPort "port") ("Port to bind http server, default: " ++ show (clckPort def))+ , Option [] ["hide-port"] (NoArg setHidePort) "Do not show the port number in the URL"+ , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostename, default: " ++ show (clckHostname 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 [] ["top"] (ReqArg setTopDir "path") ("path to directory that holds the state directory, uploads, etc")+ , 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 }+ setHidePort = ModifyConfig $ \c -> c { clckHidePort = True }+ 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 }+ 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 -> ClckwrksConfig)+parseArgs opts args =+ do case getOpt Permute opts args of+ (flags,_,[]) ->+ if any isHelp flags+ then do putStr (helpMessage opts)+ exitSuccess+ else do let f config = foldr (.) id [f | (ModifyConfig f) <- flags ] config+ return f+ (_,_,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...]"+
+ Clckwrks/IOThread.hs view
@@ -0,0 +1,48 @@+-- |this module provides a simple mechanism for adding IO operations+-- to a queue and running them in a single thread. This is useful if+-- the IO operations have side-effects which could collide if run from+-- multiple threads. For example, creating an image thumbnail and+-- storing it on disk, running LaTeX, etc.+module Clckwrks.IOThread where++import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Concurrent.Chan (Chan,newChan, readChan, writeChan)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception+import Control.Monad (forever)++data IOThread a b = IOThread { ioThreadId :: ThreadId+ , ioThreadChan :: (Chan (a, MVar (Either SomeException b)))+ }++-- |start the IO thread.+startIOThread :: (a -> IO b) -- ^ the IO function that does all the work+ -> IO (IOThread a b) -- ^ a handle to the IOThread+startIOThread f =+ do c <- newChan+ tid <- forkIO $ ioThread f c+ return (IOThread tid c)+ where+ ioThread f c =+ forever $ do (a, mvar) <- readChan c+ b <- try $ f a+ putMVar mvar b++-- |kill the IOThread+-- +-- WARNING: no attempt is made to wait for the queue to empty... we should probably have safer version that waits for the operations to complete?+killIOThread :: IOThread a b -> IO ()+killIOThread iot = killThread (ioThreadId iot)++-- |issue a request to the IO thread and get back the result+-- if the thread function throws an exception 'ioRequest' will rethrow the exception.+ioRequest :: (IOThread a b) -- ^ handle to the IOThread+ -> a -- ^ argument to the function in the IOThread+ -> IO b -- ^ value returned by the function in the IOThread+ioRequest iot a =+ do resp <- newEmptyMVar + writeChan (ioThreadChan iot) (a, resp)+ e <- readMVar resp+ case e of+ (Right r) -> return r+ (Left err) -> throwIO err
+ Clckwrks/Markup/HsColour.hs view
@@ -0,0 +1,41 @@+module Clckwrks.Markup.HsColour where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Text.HTML.SanitizeXSS (sanitizeBalance)+import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.IO (hClose)+import System.Process (waitForProcess, runInteractiveProcess)++-- | run the text through the 'markdown' executable and, if+-- successful, run the output through xss-sanitize / sanitizeBalance+-- to prevent injection attacks.+hscolour :: (MonadIO m) =>+ Maybe [String] -- ^ override command-line flags+ -> Text -- ^ markdown text+ -> m (Either Text Text) -- ^ Left error, Right html+hscolour mArgs txt = liftIO $+ do let args = case mArgs of+ Nothing -> ["-lit","-partial","-css"]+ (Just a) -> a+ (inh, outh, errh, ph) <- runInteractiveProcess "HsColour" args Nothing Nothing+ _ <- forkIO $ do T.hPutStr inh txt+ hClose inh+ mvOut <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents outh+ putMVar mvOut c+ mvErr <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents errh+ putMVar mvErr c+ ec <- waitForProcess ph+ case ec of+ (ExitFailure _) ->+ do e <- readMVar mvErr+ return (Left e)+ ExitSuccess ->+ do m <- readMVar mvOut+ return (Right ({- sanitizeBalance -} m))
+ Clckwrks/Markup/Markdown.hs view
@@ -0,0 +1,43 @@+module Clckwrks.Markup.Markdown where++import Clckwrks.Types (Trust(..))+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Text.HTML.SanitizeXSS (sanitizeBalance)+import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.IO (hClose)+import System.Process (waitForProcess, runInteractiveProcess)++-- | run the text through the 'markdown' executable. If successful,+-- and the input is marked 'Untrusted', run the output through+-- xss-sanitize / sanitizeBalance to prevent injection attacks.+markdown :: (MonadIO m) =>+ Maybe [String] -- ^ override command-line flags+ -> Trust -- ^ do we trust the author+ -> Text -- ^ markdown text+ -> m (Either Text Text) -- ^ Left error, Right html+markdown mArgs trust txt = liftIO $+ do let args = case mArgs of+ Nothing -> ["--html4tags"]+ (Just a) -> a+ (inh, outh, errh, ph) <- runInteractiveProcess "markdown" args Nothing Nothing+ _ <- forkIO $ do T.hPutStr inh txt+ hClose inh+ mvOut <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents outh+ putMVar mvOut c+ mvErr <- newEmptyMVar+ _ <- forkIO $ do c <- T.hGetContents errh+ putMVar mvErr c+ ec <- waitForProcess ph+ case ec of+ (ExitFailure _) ->+ do e <- readMVar mvErr+ return (Left e)+ ExitSuccess ->+ do m <- readMVar mvOut+ return (Right ((if (trust == Untrusted) then sanitizeBalance else id) m))
+ Clckwrks/Menu/API.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Menu.API where++import Clckwrks.Menu.Types (Menu(..), MenuItem(..), MenuName(..), MenuLink(..))+import Clckwrks.Menu.Acid (AskMenu(..))+import Clckwrks.Monad (Clck, getUnique, query)+import Clckwrks.Types (Prefix(..))+import Clckwrks.URL (ClckURL)+import Data.Text (Text, pack)+import Data.Tree (Forest, Tree(..))+import HSP hiding (escape)+import Web.Routes (showURL)++mkMenuName :: Text -> Clck url MenuName+mkMenuName name =+ do -- p <- getPrefix+ u <- getUnique+ return $ MenuName { menuPrefix = Prefix (pack "clckwrks")+ , menuTag = name+ , menuUnique = u+ }++getMenu :: GenXML (Clck ClckURL)+getMenu =+ do menu <- query AskMenu+ menuForestHTML $ menuItems menu++menuForestHTML :: Forest (MenuItem url) -> GenXML (Clck url)+menuForestHTML [] = return $ cdata ""+menuForestHTML forest =+ <ul class="page-menu">+ <% mapM menuTreeHTML forest %>+ </ul>++menuTreeHTML :: Tree (MenuItem url) -> GenXML (Clck url)+menuTreeHTML (Node menuItem subMenus) =+ case menuLink menuItem of+ (LinkURL url) ->+ do u <- showURL url+ <li>+ <a href=u><% menuTitle menuItem %></a>+ <% menuForestHTML subMenus %>+ </li>+ LinkMenu -> -- FIXME: add real support for sub menus+ <li>sub-menu (fixme)</li>+ LinkText txt ->+ <li>LinkText not implemented: <% txt %></li>+
+ Clckwrks/Menu/Acid.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards #-}+module Clckwrks.Menu.Acid+ where++import Clckwrks.Menu.Types+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)+import Control.Monad.Trans (liftIO)+import Data.Acid (AcidState, Query, Update, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable, IxSet, (@=), empty, fromList, getOne, ixSet, ixFun, insert, toList, updateIx)+import Data.SafeCopy+import Data.Text (Text)+import Data.Tree (Tree(..))+import qualified Data.Text as Text+++data MenuState url = MenuState + { menu :: Menu url+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''MenuState)++initialMenuState :: MenuState url+initialMenuState = MenuState { menu = Menu [] }++askMenu :: Query (MenuState url) (Menu url)+askMenu =+ do MenuState{..} <- ask+ return menu++addItem :: MenuItem url -> Update (MenuState url) (Menu url)+addItem item =+ do ms@MenuState{..} <- get+ let menu' = Menu $ (menuItems menu) ++ [Node item []]+ put $ ms { menu = menu' }+ return menu'++setMenu :: Menu url -> Update (MenuState url) ()+setMenu newMenu =+ do ms <- get+ put $ ms { menu = newMenu }++$(makeAcidic ''MenuState ['askMenu, 'addItem, 'setMenu])
+ Clckwrks/Menu/Edit.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleInstances, QuasiQuotes #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Menu.Edit where++import Clckwrks.Admin.Template (template)+import Clckwrks.Menu.Types (Menu(..), MenuItem(..), MenuLink(..), MenuName(..))+import Clckwrks.Menu.Acid (SetMenu(..))+import Clckwrks.Monad (Clck, query, update)+import Clckwrks.Page.Acid (PageId(..), PagesSummary(..))+import Clckwrks.Page.Types (Slug(..), slugify)+import Clckwrks.Types (Prefix(..))+import Clckwrks.URL (ClckURL(..), AdminURL(..))+import Control.Applicative ((<$>), (<|>), optional, pure)+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object)+import Data.String (fromString)+import Data.Tree (Tree(..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy.IO as LazyText+import qualified Data.Vector as Vector+import Happstack.Server (Response, internalServerError, lookBS, ok, toResponse)+import HSP+import Language.Javascript.JMacro+import Web.Routes (PathInfo, showURL, toPathInfo, fromPathInfo)+++-- MenURL ?++editMenu :: (PathInfo url) => Menu url -> Clck ClckURL Response+editMenu menu =+ do summaries <- query PagesSummary+ let clckLinks = [ (toPathInfo Blog, fromString "Blog")+ ]+ template "edit menu" (headers summaries clckLinks) $+ <%>+ <button id="add-page">Add Page</button>+ <select id="page-list"></select><br />+ <button id="add-clckwrks-link">Add Clckwrks Link</button>+ <select id="clckwrks-link"></select><br />+ <button id="add-sub-menu">Add Sub-Menu</button><br />+ <button id="remove-item">Remove</button><br />+ <button id="saveChanges">Save Changes</button><br />+ <div id="menu">+ </div>+ </%>+ where+ headers summaries clckLinks+ = do menuUpdate <- showURL (Admin MenuPOST)+ <%>+ <script type="text/javascript" src="/jstree/jquery.jstree.js" ></script>+ <% [$jmacro|+ $(document).ready(function () {+ $("#menu").jstree(`(jstree menu)`);+ var !menu = $.jstree._reference("#menu");+ // click elsewhere in document to unselect nodes+ $(document).bind("click", function (e) {+ if(!$(e.target).parents(".jstree:eq(0)").length) {+ $.jstree._focused().deselect_all();+ }+ });+ `(saveChanges menuUpdate)`;+ `(addPageMenu summaries)`;+ `(addClckwrksMenu clckLinks)`;+ `(addSubMenu)`;+ `(removeItem)`;+// `(menuEvents)`;+ });+ |]+ %>+ </%>++addClckwrksMenu :: [(Text, Text)] -> JStat+addClckwrksMenu linkInfos =+ [$jmacro|+ var select = $("#clckwrks-link");+ var links = `(data_)`;++ for (var i = 0; i < links.length; i++) {+ var option = $("<option>");+ option.attr('value', i);+ option.text(links[i].data.title);+ option.data( 'menu', links[i]);+ select.append(option);+ }++ $("#add-clckwrks-link").click(function () {+ var i = select.val();+ menu.create(null, 0, links[i], false, true);+ });++ |]+ where+ data_ = map summaryData linkInfos++ summaryData (link, ttl) =+ object [ fromString "data" .=+ object [ fromString "title" .= ttl+ ]+ , fromString "attr" .=+ object [ fromString "rel" .= "target"+ ]+ , fromString "metadata" .= object [ fromString "link" .=+ object [ fromString "linkType" .= "url"+ , fromString "linkDest" .= link+ ]+ ]+ ]+++addPageMenu :: [(PageId, Text, Maybe Slug)] -> JStat+addPageMenu pageSummaries =+ [$jmacro|+ var select = $("#page-list");+ var pages = `(data_)`;++ for (var i = 0; i < pages.length; i++) {+ var option = $("<option>");+ option.attr('value', i);+ option.text(pages[i].data.title);+ option.data( 'menu', pages[i]);+ select.append(option);+ }++ $("#add-page").click(function () {+ var i = select.val();+ menu.create(null, 0, pages[i], false, true);+ });+ |]+ where+ root =+ object [ fromString "data" .=+ object [ fromString "title" .= "menu"+ ]+ , fromString "attr" .=+ object [ fromString "rel" .= "root"+ ]+ ]+ summaryData (PageId pid, ttl, slug) =+ object [ fromString "data" .=+ object [ fromString "title" .= ttl+ ]+ , fromString "attr" .=+ object [ fromString "rel" .= "target"+ ]+ , fromString "metadata" .= object [ fromString "pid" .= pid ]+ ]+ data_ = map summaryData pageSummaries++addSubMenu :: JStat+addSubMenu =+ [$jmacro|+ $("#add-sub-menu").click(function () {+ var item = { 'attr' : { 'rel' : 'menu' } }+ menu.create(null, 0, item, false, false);+ });+ |]++removeItem :: JStat+removeItem =+ [$jmacro|+ $("#remove-item").click(function() {+ menu.remove(menu.get_selected());+ });+ |]++{-+menuEvents :: JStat+menuEvents =+ [$jmacro|+ $("#menu").bind("select_node.jstree", function (event, d) {+ if (d.inst+ alert($(d.args[0]).text());+ });+ |]+-}+saveChanges :: Text -> JStat+saveChanges menuUpdateURL =+ [$jmacro|+ $("#saveChanges").click(function () {+ var tree = $("#menu").jstree("get_json", -1);+ var json = JSON.stringify(tree);+ console.log(json);+ $.post(`(menuUpdateURL)`, { tree : json });+ });+ |]++jstree :: (PathInfo url) => Menu url -> Value+jstree menu =+ object [ fromString "types" .=+ object [ fromString "types" .=+ object [ fromString "root" .=+ object [ fromString "max_children" .= (-1 :: Int)+ ]+ , fromString "menu" .=+ object [ fromString "max_children" .= (-1 :: Int)+ ]+ , fromString "target" .=+ object [ fromString "max_children" .= (0 :: Int)+ ]+ ]+ ]+ , fromString "dnd" .=+ object [ fromString "drop_target" .= False+ , fromString "drag_target" .= False+ ]++ , fromString "ui" .=+ object [ fromString "initially_select" .= [ "tree-root" ]+ ]++ , fromString "json_data" .= menuToJSTree menu+ , fromString "plugins" .= toJSON [ "themes", "ui", "crrm", "types", "json_data", "dnd" ]+ ]++rootNode :: Value -> Value+rootNode children =+ object [ fromString "data" .=+ object [ fromString "data" .=+ object [ fromString "title" .= "menu"+ ]++ , fromString "attr" .=+ object [ fromString "id" .= "tree-root"+ ]++ , fromString "children" .= children++ ]+ ]++menuToJSTree :: (PathInfo url) => Menu url -> Value+menuToJSTree (Menu items) =+ object [ fromString "data" .= (toJSON $ map menuTreeToJSTree items)+ ]++menuTreeToJSTree :: (PathInfo url) => Tree (MenuItem url) -> Value+menuTreeToJSTree (Node item children) =+ object [ fromString "data" .=+ object [ fromString "title" .= menuTitle item ]+ , fromString "metadata" .=+ object [ fromString "menuName" .=+ object [ fromString "prefix" .= prefixText (menuPrefix (menuName item))+ , fromString "tag" .= menuTag (menuName item)+ , fromString "unique" .= menuUnique (menuName item)+ ]+ , fromString "link" .=+ case (menuLink item) of+ (LinkText txt) ->+ object [ fromString "linkType" .= "text"+ , fromString "linkDest" .= txt+ ]+ (LinkURL url) ->+ object [ fromString "linkType" .= "url"+ , fromString "linkDest" .= toPathInfo url+ ]++ ]+ , fromString "children" .=+ map menuTreeToJSTree children+ ]++newtype MenuUpdate url = MenuUpdate ([Tree (MenuUpdateItem url)]) deriving (Show)+newtype MenuUpdateItem url = MenuUpdateItem (String, Maybe MenuName, Maybe Integer, Maybe (MenuLink url)) deriving (Show)++instance (PathInfo url) => FromJSON (MenuUpdate url) where+ parseJSON (Array a) = MenuUpdate <$> mapM parseJSON (Vector.toList a)++instance (PathInfo url) => FromJSON (Tree (MenuUpdateItem url)) where+ parseJSON (Object o) =+ do ttl <- o .: (fromString "data")+ meta <- o .: (fromString "metadata")+ pid <- optional $ meta .: (fromString "pid")+ link <- do mLinkObj <- optional $ meta .: (fromString "link")+ case mLinkObj of+ Nothing -> return Nothing+ (Just linkObj) ->+ do linkType <- linkObj .: (fromString "linkType")+ case () of+ () | linkType == "text" ->+ do linkDest <- linkObj .: (fromString "linkDest")+ return (Just $ LinkText linkDest)+ | linkType == "url" ->+ do linkDest <- linkObj .: (fromString "linkDest")+ case fromPathInfo linkDest of+ (Left _) -> return Nothing+ (Right u) -> return (Just $ LinkURL u)++ menuName <- do mmno <- optional $ meta .: (fromString "menuName")+ case mmno of+ Nothing -> return Nothing+ (Just mno) ->+ do prefix <- mno .: fromString "prefix"+ tag <- mno .: fromString "tag"+ unique <- mno .: fromString "unique"+ return (Just $ MenuName (Prefix prefix) tag unique)+ children <- (o .: (fromString "children")) <|> pure Vector.empty+ return (Node (MenuUpdateItem (ttl, menuName, pid, link)) (Vector.toList children))++menuPost :: Clck ClckURL Response+menuPost =+ do t <- lookBS "tree"+ let mu = decode t :: Maybe (MenuUpdate ClckURL)+ case mu of+ Nothing ->+ internalServerError $ toResponse "menuPost: failed to decode JSON data"+ (Just u) ->+ do update (SetMenu (updateToMenu u))+ ok $ toResponse ()++updateToMenu :: (MenuUpdate ClckURL) -> Menu ClckURL+updateToMenu (MenuUpdate t) =+ Menu $ map convertItem t+ where+ convertItem :: Tree (MenuUpdateItem ClckURL) -> Tree (MenuItem ClckURL)+ convertItem (Node (MenuUpdateItem (ttl, mmn, mPageId, mLink)) children) =+ let menuName = case mmn of+ Just mn -> mn+ Nothing -> MenuName (Prefix (fromString "clckwrks")) (fromString "tag") 1+ menuItem = MenuItem { menuName = menuName+ , menuTitle = Text.pack ttl+ , menuLink =+ case mPageId of+ (Just pid) -> LinkURL (ViewPage (PageId pid))+ Nothing ->+ case mLink of+ Nothing -> LinkText (fromString "updateToMenu failed") -- Text.empty -- FIXME: this is really an error..+ (Just link) -> link+ }+ in Node menuItem (map convertItem children)+
+ Clckwrks/Menu/Types.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+module Clckwrks.Menu.Types where++import Clckwrks.Types (Prefix)+import Control.Applicative ((<$>))+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Data (Data, Typeable)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Text (Text)+import Data.Tree (Forest)+import Data.Monoid (Monoid(..))++{-++It seems natural to store a menu+sub-menus as a Forest from Data.Tree. ++However, this turns out to be very limiting in practice. Data.Tree does not give us an easy way to lookup a specific sub-menu, or insert values, etc.++A zipper will not really help us either because of the disconnect of going between Haskell and HTML/browser and back.++We want to be able to:++- retrieve the entire menu structure+- retrieve a sub-menu+- re-order a menu or sub-menu or menu item+- insert a new menu or sub-menu or menu item+- a combination of static and dynamic menu generation++Can menu items be re-used between menus?+Can items exist that are not in a menu?+Should menu names be linked to the pages they come from?++Some parts of menus are generated in code.+Some parts are generated dynmaically.+Having ids in the code menus is tricky.++Code menus should probably not need to use ids.++We probably want a way of specifying how to merge menus from multiple plugins.++Not all menu items live in the state. But some do?++Who gets control over the ordering then? Do we have a Menu type. And then an order function?++are menus Monoids?++We can create a function, menuFromTree. That generates a menu from a datastructure in the code.++But, if we run that everytime, and it generates ids that are used for sorting stuff. Then how do we ensure the ids are the same? What happens if the menu in the code changes?++We have a problem that parts of the code are blindly inserting menu entries. We do not know where they go really, just that they need to exist. Other code has to handle the presentation of those menu entries. But it does not know all the menus in advanced. ++Everyone in the system is working with partial data.++The idea of assigning a weighted value to every item, and then sorting on weight the alphabet is attractive in its simpleness. But simple does not mean right. One problem is that a developer might assign some very high or very low weight to their menu items. Or, different libraries might assign different weights, but you want the order the other way.++In the end, only the user can decide what order they want the menu in. And they would like to be able to override everything. But, they don't want to have to do everything manually.++components from different vendors need ways to create unique ids. Guessing at globally unique ids is a sure plan for failure.++Seems that part of the component system should be a unique id generator. Part of that should be a unique prefix that the module can use. ++each component should be registered with a unique prefix. ++So the code generated menus could then use that to help name menu entries++-}++data MenuName = MenuName+ { menuPrefix :: Prefix+ , menuTag :: Text+ , menuUnique :: Integer -- an integer which ensures this name is unique. However, it may not be stable across runs.+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''MenuName)++data MenuLink url+ = LinkText Text+ | LinkURL url+ | LinkMenu -- (Menu url)+ deriving (Eq, Read, Show, Data, Typeable)++data MenuItem url = MenuItem+ { menuName :: MenuName+ , menuTitle :: Text+ , menuLink :: MenuLink url+ }+ deriving (Eq, Read, Show, Data, Typeable)++data Menu url+ = Menu { menuItems :: Forest (MenuItem url)+ }+ deriving (Eq, Read, Show, Data, Typeable)++$(deriveSafeCopy 1 'base ''MenuLink)+$(deriveSafeCopy 1 'base ''MenuItem)+$(deriveSafeCopy 1 'base ''Menu)++instance Monoid (Menu url) where+ mempty = Menu { menuItems = [] }+ (Menu a) `mappend` (Menu b) = Menu $ a ++ b
+ Clckwrks/Monad.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings #-}+module Clckwrks.Monad+ ( Clck+ , ClckPlugins+ , ClckT(..)+ , ClckForm+ , ClckFormT+ , ClckFormError(..)+ , ChildType(..)+ , ClckwrksConfig(..)+ , AttributeType(..)+ , Theme(..)+ , ThemeName+ , calcBaseURI+ , evalClckT+ , execClckT+ , runClckT+ , mapClckT+ , withRouteClckT+ , ClckState(..)+ , getUserId+ , Content(..)+ , markupToContent+-- , addPreProcessor+ , addAdminMenu+ , addPreProc+ , setCurrentPage+-- , getPrefix+ , getEnableAnalytics+ , getUnique+ , setUnique+ , requiresRole+ , requiresRole_+ , query+ , update+ , nestURL+ , segments+ , transform+ )+where++import Clckwrks.Admin.URL (AdminURL(..))+import Clckwrks.Acid (Acid(..), GetAcidState(..))+import Clckwrks.Page.Types (Markup(..), runPreProcessors)+import Clckwrks.Menu.Acid (MenuState)+import Clckwrks.Page.Acid (PageState, PageId)+import Clckwrks.ProfileData.Acid (ProfileDataState, ProfileDataError(..), HasRole(..))+import Clckwrks.ProfileData.Types (Role(..))+import Clckwrks.Types (Prefix, Trust(Trusted))+import Clckwrks.Unauthorized (unauthorizedPage)+import Clckwrks.URL (ClckURL(..))+import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many)+import Control.Monad (MonadPlus, foldM)+import Control.Monad.State (MonadState, StateT, evalStateT, execStateT, get, mapStateT, modify, put, runStateT)+import Control.Monad.Reader (MonadReader, ReaderT, mapReaderT)+import Control.Monad.Trans (MonadIO(liftIO), lift)+import Control.Concurrent.STM (TVar, readTVar, writeTVar, atomically)+import Data.Aeson (Value(..))+import Data.Acid (AcidState, EventState, EventResult, QueryEvent, UpdateEvent)+import Data.Acid.Advanced (query', update')+import Data.Attoparsec.Text.Lazy (Parser, parseOnly, char, stringCI, try, takeWhile, takeWhile1)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Monoid (mappend, mconcat)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import Data.ByteString.Lazy as LB (ByteString)+import Data.ByteString.Lazy.UTF8 as LB (toString)+import Data.Data (Data, Typeable)+import Data.Map (Map)+import Data.SafeCopy (SafeCopy(..))+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder, fromText)+import qualified Data.Text.Lazy.Builder as B+import Data.Time.Clock (UTCTime)+import Data.Time.Format (formatTime)+import Happstack.Auth (AuthProfileURL(..), AuthURL(..), AuthState, ProfileState, UserId)+import qualified Happstack.Auth as Auth++import Happstack.Server (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Input, Response, HasRqData(..), ServerPartT, UnWebT, mapServerPartT, escape)+import Happstack.Server.HSP.HTML () -- ToMessage XML instance+import Happstack.Server.Internal.Monads (FilterFun)+import HSP hiding (Request, escape)+import HSP.Google.Analytics (UACCT)+import HSP.ServerPartT ()+import HSX.XMLGenerator (XMLGen(..))+import HSX.JMacro (IntegerSupply(..))+import Language.Javascript.JMacro+import Prelude hiding (takeWhile)+import System.Locale (defaultTimeLocale)+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.String (renderHtml)+import Text.Reform (CommonFormError, Form, FormError(..))+import Web.Routes (URL, MonadRoute(askRouteFn), RouteT(RouteT, unRouteT), mapRouteT, showURL, withRouteT)+import Web.Plugins.Core (Plugins, getPluginsSt, modifyPluginsSt)+import qualified Web.Routes as R+import Web.Routes.Happstack (seeOtherURL) -- imported so that instances are scope even though we do not use them here+import Web.Routes.XMLGenT () -- imported so that instances are scope even though we do not use them here++type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ([TL.Text -> ClckT ClckURL IO TL.Text])++type ThemeName = T.Text++data Theme = Theme+ { themeName :: ThemeName+ , _themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>+ T.Text+ -> headers+ -> body+ -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ , themeBlog :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+ , themeDataDir :: IO FilePath+ }++data ClckwrksConfig = ClckwrksConfig+ { clckHostname :: String -- ^ external name of the host+ , clckPort :: Int -- ^ port to listen on+ , clckHidePort :: Bool -- ^ hide port number in URL (useful when running behind a reverse proxy)+ , clckJQueryPath :: FilePath -- ^ path to @jquery.js@ on disk+ , clckJQueryUIPath :: FilePath -- ^ path to @jquery-ui.js@ on disk+ , clckJSTreePath :: FilePath -- ^ path to @jstree.js@ on disk+ , clckJSON2Path :: FilePath -- ^ path to @JSON2.js@ on disk+ , clckTopDir :: Maybe FilePath -- ^ path to top-level directory for all acid-state files/file uploads/etc+ , clckEnableAnalytics :: Bool -- ^ enable google analytics+ , clckInitHook :: T.Text -> ClckState -> ClckwrksConfig -> IO (ClckState, ClckwrksConfig) -- ^ init hook+ }++-- | calculate the baseURI from the 'clckHostname', 'clckPort' and 'clckHidePort' options+calcBaseURI :: ClckwrksConfig -> T.Text+calcBaseURI c = Text.pack $ "http://" ++ (clckHostname c) ++ if ((clckPort c /= 80) && (clckHidePort c == False)) then (':' : show (clckPort c)) else ""++data ClckState+ = ClckState { acidState :: Acid+ , currentPage :: PageId+ , uniqueId :: TVar Integer -- only unique for this request+ , adminMenus :: [(T.Text, [(T.Text, T.Text)])]+ , enableAnalytics :: Bool -- ^ enable Google Analytics+ , plugins :: ClckPlugins -- Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ([TL.Text -> ClckT ClckURL IO TL.Text])+ }++newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a }+ deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)++instance (Happstack m) => Happstack (ClckT url m)++-- | evaluate a 'ClckT' returning the inner monad+--+-- similar to 'evalStateT'.+evalClckT :: (Monad m) =>+ (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'+ -> ClckState -- ^ initial 'ClckState'+ -> ClckT url m a -- ^ 'ClckT' to evaluate+ -> m a+evalClckT showFn clckState m = evalStateT (unRouteT (unClckT m) showFn) clckState++-- | execute a 'ClckT' returning the final 'ClckState'+--+-- similar to 'execStateT'.+execClckT :: (Monad m) =>+ (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'+ -> ClckState -- ^ initial 'ClckState'+ -> ClckT url m a -- ^ 'ClckT' to evaluate+ -> m ClckState+execClckT showFn clckState m =+ execStateT (unRouteT (unClckT m) showFn) clckState++-- | run a 'ClckT'+--+-- similar to 'runStateT'.+runClckT :: (Monad m) =>+ (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'+ -> ClckState -- ^ initial 'ClckState'+ -> ClckT url m a -- ^ 'ClckT' to evaluate+ -> m (a, ClckState)+runClckT showFn clckState m =+ runStateT (unRouteT (unClckT m) showFn) clckState++-- | map a transformation function over the inner monad+--+-- similar to 'mapStateT'+mapClckT :: (m (a, ClckState) -> n (b, ClckState)) -- ^ transformation function+ -> ClckT url m a -- ^ initial monad+ -> ClckT url n b+mapClckT f (ClckT r) = ClckT $ mapRouteT (mapStateT f) r++-- | error returned when a reform 'Form' fails to validate+data ClckFormError+ = ClckCFE (CommonFormError [Input])+ | PDE ProfileDataError+ | EmptyUsername+ deriving (Show)++instance FormError ClckFormError where+ type ErrorInputType ClckFormError = [Input]+ commonFormError = ClckCFE++-- | ClckForm - type for reform forms+type ClckFormT error m = Form m [Input] error [XMLGenT m XML] ()+type ClckForm url = Form (ClckT url (ServerPartT IO)) [Input] ClckFormError [XMLGenT (ClckT url (ServerPartT IO)) XML] ()++-- | update the 'currentPage' field of 'ClckState'+setCurrentPage :: PageId -> Clck url ()+setCurrentPage pid =+ modify $ \s -> s { currentPage = pid }++-- getPrefix :: Clck url Prefix+-- getPrefix = componentPrefix <$> get++setUnique :: Integer -> Clck url ()+setUnique i =+ do u <- uniqueId <$> get+ liftIO $ atomically $ writeTVar u i++-- | get a unique 'Integer'.+--+-- Only unique for the current request+getUnique :: Clck url Integer+getUnique =+ do u <- uniqueId <$> get+ liftIO $ atomically $ do i <- readTVar u+ writeTVar u (succ i)+ return i++-- | get the 'Bool' value indicating if Google Analytics should be enabled or not+getEnableAnalytics :: (Functor m, MonadState ClckState m) => m Bool+getEnableAnalytics = enableAnalytics <$> get++addAdminMenu :: (Monad m) => (T.Text, [(T.Text, T.Text)]) -> ClckT url m ()+addAdminMenu (category, entries) =+ modify $ \cs ->+ let oldMenus = adminMenus cs+ newMenus = Map.toAscList $ Map.insertWith List.union category entries $ Map.fromList oldMenus+ in cs { adminMenus = newMenus }++-- | change the route url+withRouteClckT :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> url -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> ClckT url m a+ -> ClckT url' m a+withRouteClckT f (ClckT routeT) = (ClckT $ withRouteT f routeT)++type Clck url = ClckT url (ServerPartT IO)++instance IntegerSupply (Clck url) where+ nextInteger = getUnique++instance ToJExpr Value where+ toJExpr (Object obj) = ValExpr $ JHash $ Map.fromList $ map (\(k,v) -> (T.unpack k, toJExpr v)) (HashMap.toList obj)+ toJExpr (Array vs) = ValExpr $ JList $ map toJExpr (Vector.toList vs)+ toJExpr (String s) = ValExpr $ JStr $ T.unpack s+ toJExpr (Number n) = ValExpr $ JDouble $ realToFrac n+ toJExpr (Bool True) = ValExpr $ JVar $ StrI "true"+ toJExpr (Bool False) = ValExpr $ JVar $ StrI "false"+ toJExpr Null = ValExpr $ JVar $ StrI "null"++instance ToJExpr Text.Text where+ toJExpr t = ValExpr $ JStr $ T.unpack t++nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a+nestURL f (ClckT r) = ClckT $ R.nestURL f r++instance (Monad m) => MonadRoute (ClckT url m) where+ type URL (ClckT url m) = url+ askRouteFn = ClckT $ askRouteFn++-- | similar to the normal acid-state 'query' except it automatically gets the correct 'AcidState' handle from the environment+query :: forall event m. (QueryEvent event, GetAcidState m (EventState event), Functor m, MonadIO m, MonadState ClckState m) => event -> m (EventResult event)+query event =+ do as <- getAcidState+ query' (as :: AcidState (EventState event)) event++-- | similar to the normal acid-state 'update' except it automatically gets the correct 'AcidState' handle from the environment+update :: forall event m. (UpdateEvent event, GetAcidState m (EventState event), Functor m, MonadIO m, MonadState ClckState m) => event -> m (EventResult event)+update event =+ do as <- getAcidState+ update' (as :: AcidState (EventState event)) event++instance (GetAcidState m st) => GetAcidState (XMLGenT m) st where+ getAcidState = XMLGenT getAcidState++instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthState where+ getAcidState = (acidAuth . acidState) <$> get++instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileState where+ getAcidState = (acidProfile . acidState) <$> get++instance (Functor m, Monad m) => GetAcidState (ClckT url m) (MenuState ClckURL) where+ getAcidState = (acidMenu . acidState) <$> get++instance (Functor m, Monad m) => GetAcidState (ClckT url m) PageState where+ getAcidState = (acidPage . acidState) <$> get++instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileDataState where+ getAcidState = (acidProfileData . acidState) <$> get++-- | The the 'UserId' of the current user. While return 'Nothing' if they are not logged in.+getUserId :: (Happstack m, GetAcidState m AuthState, GetAcidState m ProfileState) => m (Maybe UserId)+getUserId =+ do authState <- getAcidState+ profileState <- getAcidState+ Auth.getUserId authState profileState++-- * XMLGen / XMLGenerator instances for Clck++instance (Functor m, Monad m) => XMLGen (ClckT url m) where+ type XMLType (ClckT url m) = XML+ newtype ChildType (ClckT url m) = ClckChild { unClckChild :: XML }+ newtype AttributeType (ClckT url m) = ClckAttr { unClckAttr :: Attribute }+ genElement n attrs children =+ do attribs <- map unClckAttr <$> asAttr attrs+ childer <- flattenCDATA . map (unClckChild) <$> asChild children+ XMLGenT $ return (Element+ (toName n)+ attribs+ childer+ )+ xmlToChild = ClckChild+ pcdataToChild = xmlToChild . pcdata++flattenCDATA :: [XML] -> [XML]+flattenCDATA cxml =+ case flP cxml [] of+ [] -> []+ [CDATA _ ""] -> []+ xs -> xs+ where+ flP :: [XML] -> [XML] -> [XML]+ flP [] bs = reverse bs+ flP [x] bs = reverse (x:bs)+ flP (x:y:xs) bs = case (x,y) of+ (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+ _ -> flP (y:xs) (x:bs)++instance (Functor m, Monad m) => IsAttrValue (ClckT url m) T.Text where+ toAttrValue = toAttrValue . T.unpack++instance (Functor m, Monad m) => IsAttrValue (ClckT url m) TL.Text where+ toAttrValue = toAttrValue . TL.unpack++instance (Functor m, Monad m) => EmbedAsAttr (ClckT url m) Attribute where+ asAttr = return . (:[]) . ClckAttr++instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Char) where+ asAttr (n := c) = asAttr (n := [c])++instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Bool) where+ asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")+ asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Integer) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (IsName n) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where+ asAttr (n := u) =+ do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))++instance (IsName n) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where+ asAttr (n := u) =+ do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+++{-+instance EmbedAsAttr Clck (Attr String AuthURL) where+ asAttr (n := u) =+ do url <- showURL (W_Auth u)+ asAttr $ MkAttr (toName n, pAttrVal url)+-}++instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)++instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Char where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . (:[])++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) String where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Int where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Integer where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Double where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Float where+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) TL.Text where+ asChild = asChild . TL.unpack++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) T.Text where+ asChild = asChild . T.unpack++instance (EmbedAsChild (ClckT url1 m) a, url1 ~ url2) => EmbedAsChild (ClckT url1 m) (ClckT url2 m a) where+ asChild c =+ do a <- XMLGenT c+ asChild a++instance (Functor m, MonadIO m, EmbedAsChild (ClckT url m) a) => EmbedAsChild (ClckT url m) (IO a) where+ asChild c =+ do a <- XMLGenT (liftIO c)+ asChild a+++{-+instance EmbedAsChild Clck TextHtml where+ asChild = XMLGenT . return . (:[]) . ClckChild . cdata . T.unpack . unTextHtml+-}+instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) XML where+ asChild = XMLGenT . return . (:[]) . ClckChild++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Html where+ asChild = XMLGenT . return . (:[]) . ClckChild . cdata . renderHtml++instance (Functor m, Monad m, Happstack m) => EmbedAsChild (ClckT url m) Markup where+ asChild mrkup = asChild =<< (XMLGenT $ markupToContent mrkup)++instance (Functor m, MonadIO m, Happstack m) => EmbedAsChild (ClckT url m) ClckFormError where+ asChild formError = asChild (show formError)++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) () where+ asChild () = return []++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) UTCTime where+ asChild = asChild . formatTime defaultTimeLocale "%a, %F @ %r"++instance (Functor m, Monad m, EmbedAsChild (ClckT url m) a) => EmbedAsChild (ClckT url m) (Maybe a) where+ asChild Nothing = asChild ()+ asChild (Just a) = asChild a++instance (Functor m, Monad m) => AppendChild (ClckT url m) XML where+ appAll xml children = do+ chs <- children+ case xml of++ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n as (cs ++ (map unClckChild chs))++instance (Functor m, Monad m) => SetAttr (ClckT url m) XML where+ setAll xml hats = do+ attrs <- hats+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n (foldr (:) as (map unClckAttr attrs)) cs++instance (Functor m, Monad m) => XMLGenerator (ClckT url m)++-- | a wrapper which identifies how to treat different 'Text' values when attempting to embed them.+--+-- In general 'Content' values have already been+-- flatten/preprocessed/etc and are now basic formats like+-- @text/plain@, @text/html@, etc+data Content+ = TrustedHtml T.Text+ | PlainText T.Text+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Content where+ asChild (TrustedHtml html) = asChild $ cdata (T.unpack html)+ asChild (PlainText txt) = asChild $ pcdata (T.unpack txt)++-- | convert 'Markup' to 'Content' that can be embedded. Generally by running the pre-processors needed.+-- markupToContent :: (Functor m, MonadIO m, Happstack m) => Markup -> ClckT url m Content+markupToContent :: (Functor m, MonadIO m, Happstack m) =>+ Markup+ -> ClckT url m Content+markupToContent Markup{..} =+ do clckState <- get+ transformers <- liftIO $ getPluginsSt (plugins clckState)+ (markup', clckState') <- liftIO $ runClckT undefined clckState (foldM (\txt pp -> pp txt) (TL.fromStrict markup) transformers)+ put clckState'+ e <- liftIO $ runPreProcessors preProcessors trust (TL.toStrict markup')+ case e of+ (Left err) -> return (PlainText err)+ (Right html) -> return (TrustedHtml html)++addPreProc :: (MonadIO m) =>+ Plugins theme n hook config [TL.Text -> ClckT ClckURL IO TL.Text]+ -> (TL.Text -> ClckT ClckURL IO TL.Text)+ -> m ()+addPreProc plugins p =+ modifyPluginsSt plugins $ \ps -> p : ps++-- * Preprocess++data Segment cmd+ = TextBlock T.Text+ | Cmd cmd+ deriving Show++instance Functor Segment where+ fmap f (TextBlock t) = TextBlock t+ fmap f (Cmd c) = Cmd (f c)++transform :: (Monad m) =>+ (cmd -> m Builder)+ -> [Segment cmd]+ -> m Builder+transform f segments =+ do bs <- mapM (transformSegment f) segments+ return (mconcat bs)++transformSegment :: (Monad m) =>+ (cmd -> m Builder)+ -> Segment cmd+ -> m Builder+transformSegment f (TextBlock t) = return (B.fromText t)+transformSegment f (Cmd cmd) = f cmd++segments :: T.Text+ -> Parser a+ -> Parser [Segment a]+segments name p =+ many (cmd name p <|> plainText)++cmd :: T.Text -> Parser cmd -> Parser (Segment cmd)+cmd n p =+ do char '{'+ ((try $ do stringCI n+ char '|'+ r <- p+ char '}'+ return (Cmd r))+ <|>+ (do t <- takeWhile1 (/= '{')+ return $ TextBlock (T.cons '{' t)))++plainText :: Parser (Segment cmd)+plainText =+ do t <- takeWhile1 (/= '{')+ return $ TextBlock t++-- * Require Role++requiresRole_ :: (Happstack m) => (ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text) -> Set Role -> url -> ClckT u m url+requiresRole_ showFn role url =+ ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn++requiresRole :: (Happstack m) => Set Role -> url -> ClckT ClckURL m url+requiresRole role url =+ do mu <- getUserId+ case mu of+ Nothing -> escape $ seeOtherURL (Auth $ AuthURL A_Login)+ (Just uid) ->+ do r <- query (HasRole uid role)+ if r+ then return url+ else escape $ unauthorizedPage ("You do not have permission to view this page." :: T.Text)
+ Clckwrks/Page/API.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleContexts, RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.API+ ( PageId(..)+ , getPage+ , getPageId+ , getPageTitle+ , getPageTitleSlug+ , getPageContent+ , getPagesSummary+ , getPageSummary+ , getPageMenu+ , getPosts+ , extractExcerpt+ , getBlogTitle+ , googleAnalytics+ ) where++import Clckwrks.Acid+import Clckwrks.Monad+import Clckwrks.Page.Acid+import Clckwrks.URL+import Control.Applicative+import Control.Monad.State+import Control.Monad.Trans (MonadIO)+import Data.Text (Text, empty)+import qualified Data.Text as Text+import Clckwrks.Page.Types (toSlug)+import Happstack.Server+import HSP hiding (escape)+import HSP.Google.Analytics (analyticsAsync)+import Text.HTML.TagSoup++getPage :: Clck url Page+getPage =+ do ClckState{..} <- get+ mPage <- query (PageById currentPage)+ case mPage of+ Nothing -> escape $ internalServerError $ toResponse ("getPage: invalid PageId " ++ show (unPageId currentPage))+ (Just p) -> return p++getPageId :: Clck url PageId+getPageId = currentPage <$> get++getPageTitle :: Clck url Text+getPageTitle = pageTitle <$> getPage++getPageTitleSlug :: Clck url (Text, Maybe Slug)+getPageTitleSlug =+ do p <- getPage+ return (pageTitle p, pageSlug p)++getPageContent :: Clck url Content+getPageContent =+ do mrkup <- pageSrc <$> getPage+ markupToContent mrkup++getPagesSummary :: Clck url [(PageId, Text, Maybe Slug)]+getPagesSummary = query PagesSummary++getPageMenu :: GenXML (Clck ClckURL)+getPageMenu =+ do ps <- query PagesSummary+ case ps of+ [] -> <div>No pages found.</div>+ _ -> <ul class="page-menu">+ <% mapM (\(pid, ttl, slug) -> <li><a href=(ViewPageSlug pid (toSlug ttl slug)) title=ttl><% ttl %></a></li>) ps %>+ </ul>++getPageSummary :: PageId -> Clck url Content+getPageSummary pid =+ do mPage <- query (PageById pid)+ case mPage of+ Nothing ->+ return $ PlainText $ Text.pack $ "Invalid PageId " ++ (show $ unPageId pid)+ (Just pge) ->+ extractExcerpt pge++getBlogTitle :: Clck url Text+getBlogTitle = query GetBlogTitle++extractExcerpt :: (MonadIO m, Functor m, Happstack m) =>+ Page+ -> ClckT url m Content+extractExcerpt Page{..} =+ case pageExcerpt of+ (Just excerpt) ->+ markupToContent excerpt+ Nothing ->+ do c <- markupToContent pageSrc+ case c of+ (TrustedHtml html) ->+ let tags = parseTags html+ paragraphs = sections (~== "<p>") tags+ paragraph = case paragraphs of+ [] -> Text.pack "no summary available."+ (p:ps) -> renderTags $ takeThrough (not . isTagCloseName (Text.pack "p")) $ filter (not . isTagOpenName (Text.pack "img")) p+ in return (TrustedHtml paragraph)+ (PlainText text) ->+ return (PlainText text)++takeThrough :: (a -> Bool) -> [a] -> [a]+takeThrough _ [] = []+takeThrough f (p:ps)+ | f p = p : takeThrough f ps+ | otherwise = []++-- | get all posts, sorted reverse cronological+getPosts :: XMLGenT (Clck url) [Page]+getPosts = query AllPosts++-- | create a google analytics tracking code block+--+-- This will under two different conditions:+--+-- * the 'enableAnalytics' field in 'ClckState' is 'False'+--+-- * the 'uacct' field in 'PageState' is 'Nothing'+googleAnalytics :: XMLGenT (Clck url) XML+googleAnalytics =+ do enabled <- getEnableAnalytics+ case enabled of+ False -> return $ cdata ""+ True ->+ do muacct <- query GetUACCT+ case muacct of+ Nothing -> return $ cdata ""+ (Just uacct) ->+ analyticsAsync uacct
+ Clckwrks/Page/Acid.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards, OverloadedStrings #-}+module Clckwrks.Page.Acid+ ( module Clckwrks.Page.Types+ -- * state+ , PageState+ , initialPageState+ -- * events+ , NewPage(..)+ , PageById(..)+ , GetPageTitle(..)+ , IsPublishedPage(..)+ , PagesSummary(..)+ , UpdatePage(..)+ , AllPosts(..)+ , GetFeedConfig(..)+ , SetFeedConfig(..)+ , GetBlogTitle(..)+ , GetUACCT(..)+ , SetUACCT(..)+ ) where++import Clckwrks.Page.Types (Markup(..), PublishStatus(..), PreProcessor(..), PageId(..), PageKind(..), Page(..), Pages(..), FeedConfig(..), Slug(..), initialFeedConfig, slugify)+import Clckwrks.Types (Trust(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, modify, put)+import Control.Monad.Trans (liftIO)+import Data.Acid (AcidState, Query, Update, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable, IxSet, (@=), Proxy(..), empty, fromList, getOne, ixSet, ixFun, insert, toList, toDescList, updateIx)+import Data.Maybe (fromJust)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.String (fromString)+import Data.Text (Text)+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX(posixSecondsToUTCTime)+import qualified Data.Text as Text+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Happstack.Auth (UserId(..))+import HSP.Google.Analytics (UACCT)++$(deriveSafeCopy 0 'base ''UACCT)++data PageState_001 = PageState_001+ { nextPageId_001 :: PageId+ , pages_001 :: IxSet Page+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageState_001)++data PageState_002 = PageState_002+ { nextPageId_002 :: PageId+ , pages_002 :: IxSet Page+ , feedConfig_002 :: FeedConfig+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''PageState_002)++instance Migrate PageState_002 where+ type MigrateFrom PageState_002 = PageState_001+ migrate (PageState_001 npi pgs) =+ PageState_002 npi pgs (FeedConfig { feedUUID = fromJust $ UUID.fromString "fa6cf090-84d7-11e1-8001-0021cc712949"+ , feedTitle = fromString "Untitled Feed"+ , feedLink = fromString ""+ , feedAuthorName = fromString "Anonymous"+ })++data PageState = PageState+ { nextPageId :: PageId+ , pages :: IxSet Page+ , feedConfig :: FeedConfig+ , uacct :: Maybe UACCT+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 3 'extension ''PageState)++instance Migrate PageState where+ type MigrateFrom PageState = PageState_002+ migrate (PageState_002 npi pgs fc) =+ PageState npi pgs fc Nothing++initialPageState :: IO PageState+initialPageState =+ do fc <- initialFeedConfig+ return $ PageState { nextPageId = PageId 2+ , pages = fromList [ Page { pageId = PageId 1+ , pageAuthor = UserId 1+ , pageTitle = "This title rocks!"+ , pageSlug = Just $ slugify "This title rocks!"+ , pageSrc = Markup { preProcessors = [ Markdown ]+ , trust = Trusted+ , markup = "This is the body!"+ }+ , pageExcerpt = Nothing+ , pageDate = posixSecondsToUTCTime 1334089928+ , pageUpdated = posixSecondsToUTCTime 1334089928+ , pageStatus = Published+ , pageKind = PlainPage+ , pageUUID = fromJust $ UUID.fromString "c306fe3a-8346-11e1-8001-0021cc712949"+ }+ ]+ , feedConfig = fc+ , uacct = Nothing+ }++pageById :: PageId -> Query PageState (Maybe Page)+pageById pid =+ do pgs <- pages <$> ask+ return $ getOne $ pgs @= pid++-- | get the 'pageTitle' for 'PageId'+getPageTitle :: PageId -> Query PageState (Maybe (Text, Maybe Slug))+getPageTitle pid =+ do mPage <- pageById pid+ case mPage of+ Nothing -> return $ Nothing+ (Just page) -> return $ Just (pageTitle page, pageSlug page)++-- | check if the 'PageId' corresponds to a published 'PageId'+isPublishedPage :: PageId -> Query PageState Bool+isPublishedPage pid =+ do pgs <- pages <$> ask+ case getOne $ pgs @= pid of+ Nothing -> return False+ (Just page) -> return $ pageStatus page == Published++pagesSummary :: Query PageState [(PageId, Text, Maybe Slug)]+pagesSummary =+ do pgs <- pages <$> ask+ return $ map (\page -> (pageId page, pageTitle page, pageSlug page)) (toList pgs)++updatePage :: Page -> Update PageState (Maybe String)+updatePage page =+ do ps@PageState{..} <- get+ case getOne $ pages @= (pageId page) of+ Nothing -> return $ Just $ "updatePage: Invalid PageId " ++ show (unPageId $ pageId page)+ (Just _) ->+ do put $ ps { pages = updateIx (pageId page) page pages }+ return Nothing++newPage :: PageKind -> UserId -> UUID -> UTCTime -> Update PageState Page+newPage pk uid uuid now =+ do ps@PageState{..} <- get+ let page = Page { pageId = nextPageId+ , pageAuthor = uid+ , pageTitle = "Untitled"+ , pageSlug = Nothing+ , pageSrc = Markup { preProcessors = [ Markdown ]+ , trust = Trusted+ , markup = Text.empty+ }+ , pageExcerpt = Nothing+ , pageDate = now+ , pageUpdated = now+ , pageStatus = Draft+ , pageKind = pk+ , pageUUID = uuid+ }+ put $ ps { nextPageId = PageId $ succ $ unPageId nextPageId+ , pages = insert page pages+ }+ return page++getFeedConfig :: Query PageState FeedConfig+getFeedConfig =+ do PageState{..} <- ask+ return feedConfig++getBlogTitle :: Query PageState Text+getBlogTitle =+ do PageState{..} <- ask+ return (feedTitle feedConfig)++setFeedConfig :: FeedConfig -> Update PageState ()+setFeedConfig fc =+ do ps <- get+ put $ ps { feedConfig = fc }++-- | get all 'Published' posts, sorted reverse cronological+allPosts :: Query PageState [Page]+allPosts =+ do pgs <- pages <$> ask+ return $ toDescList (Proxy :: Proxy UTCTime) (pgs @= Post @= Published)++-- | get the 'UACCT' for Google Analytics+getUACCT :: Query PageState (Maybe UACCT)+getUACCT = uacct <$> ask++-- | set the 'UACCT' for Google Analytics+setUACCT :: Maybe UACCT -> Update PageState ()+setUACCT mua = modify $ \ps -> ps { uacct = mua }++$(makeAcidic ''PageState+ [ 'newPage+ , 'pageById+ , 'getPageTitle+ , 'isPublishedPage+ , 'pagesSummary+ , 'updatePage+ , 'allPosts+ , 'getFeedConfig+ , 'setFeedConfig+ , 'getBlogTitle+ , 'getUACCT+ , 'setUACCT+ ])
+ Clckwrks/Page/Atom.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.Atom where++import Control.Monad.Trans (liftIO)+import Clckwrks.Monad+import Clckwrks.Page.Acid+import Clckwrks.Page.Types+import Clckwrks.ProfileData.Acid+import Clckwrks.URL+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import Data.Maybe (fromMaybe)+import Data.String (fromString)+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (formatTime)+import Data.UUID (toString)+import Happstack.Server (Response, ok, toResponseBS)+import HSP+import HSP.XML (renderXML)+import System.Locale (defaultTimeLocale)++atom :: FeedConfig -- ^ feed configuration+ -> [Page] -- ^ pages to publish in feed+ -> Clck ClckURL XML+atom FeedConfig{..} pages =+ unXMLGenT $ <feed xmlns="http://www.w3.org/2005/Atom">+ <title><% feedTitle %></title>+ <link type="text/html" href=Blog />+ <link rel="self" type="application/atom+xml" href=AtomFeed />+ <author>+ <name><% feedAuthorName %></name>+ </author>+ <updated><% atomDate $ mostRecentUpdate pages %></updated>+ <id><% "urn:uuid:" ++ toString feedUUID %></id>+ <% mapM entry pages %>+ </feed>++mostRecentUpdate :: [Page] -- ^ pages to consider+ -> UTCTime -- ^ most recent updated time+mostRecentUpdate [] = posixSecondsToUTCTime 0+mostRecentUpdate pages =+ maximum $ map pageUpdated pages++entry :: Page+ -> Clck ClckURL XML+entry Page{..} =+ unXMLGenT $ <entry>+ <title><% pageTitle %></title>+ <link href=(ViewPageSlug pageId (toSlug pageTitle pageSlug)) />+ <id><% "urn:uuid:" ++ toString pageUUID %></id>+ <% author %>+ <updated><% atomDate pageUpdated %></updated>+ <% atomContent pageSrc %>+ </entry>+ where+ author :: XMLGenT (Clck ClckURL) XML+ author =+ do mu <- query $ UsernameForId pageAuthor+ case mu of+ Nothing -> return $ cdata ""+ (Just n)+ | Text.null n ->+ return $ cdata ""+ | otherwise ->+ <author>+ <name><% n %></name>+ </author>++atomDate :: UTCTime -> String+atomDate time =+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" time++atomContent :: Markup -> Clck ClckURL XML+atomContent markup =+ do c <- markupToContent markup+ case c of+ (PlainText txt) ->+ unXMLGenT $ <content type="text"><% txt %></content>+ (TrustedHtml html) ->+ unXMLGenT $ <content type="html"><% html %></content>++handleAtomFeed :: Clck ClckURL Response+handleAtomFeed =+ do ps <- query AllPosts+ feedConfig <- query GetFeedConfig+ xml <- atom feedConfig ps+ ok $ toResponseBS (fromString "application/atom+xml;charset=utf-8") (UTF8.fromString $ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" ++ renderXML xml)
+ Clckwrks/Page/PreProcess.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Page.PreProcess where++import Control.Monad.Trans (MonadIO(..))+import Control.Applicative ((<*>), (*>), (<$>), (<|>), optional)+import Clckwrks.Monad (ClckT, ClckState, transform, query, segments)+import Clckwrks.Page.Acid (GetPageTitle(..))+import Clckwrks.URL (ClckURL(ViewPageSlug))+import Clckwrks.Page.Types (PageId(..), slugify, toSlug)+import Data.Attoparsec.Text.Lazy (Parser, Result(..), anyChar, char, choice, decimal, parse, skipMany, space, stringCI, skipMany, try)+import Data.Attoparsec.Combinator (many1, manyTill, skipMany)+import Data.String (fromString)+import Data.Text (Text, pack)+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as B+import HSP+import HSP.HTML (renderAsHTML)+import Web.Routes (showURL)++-- TODO: move to reusable module+parseAttr :: Text -> Parser ()+parseAttr name =+ do skipMany space+ stringCI name+ skipMany space+ char '='+ skipMany space++qchar :: Parser Char+qchar = (char '\\' *> anyChar) <|> anyChar++text :: Parser Text+text = pack <$> many1 qchar++qtext :: Parser Text+qtext = pack <$> (char '"' *> manyTill qchar (try $ char '"'))++data PageCmd+ = LinkPage PageId (Maybe Text)+ deriving (Eq, Ord, Show)++pageId :: Parser PageCmd+pageId = LinkPage <$> (parseAttr (fromString "id") *> (PageId <$> decimal)) <*> (optional $ parseAttr (fromString "title") *> qtext)++parseCmd :: Parser PageCmd+parseCmd = pageId++pageCmd :: (Functor m, MonadIO m) =>+ (ClckURL -> [(Text, Maybe Text)] -> Text)+ -> TL.Text+ -> ClckT url m TL.Text+pageCmd clckShowURL txt =+ case parse (segments "page" parseCmd) txt of+ (Fail _ _ e) -> return (TL.pack e)+ (Done _ segments) ->+ do b <- transform (applyCmd clckShowURL) segments+ return $ B.toLazyText b++applyCmd clckShowURL l@(LinkPage pid mTitle) =+ do (ttl, slug) <-+ case mTitle of+ (Just t) -> return (t, Just $ slugify t)+ Nothing -> do mttl <- query (GetPageTitle pid)+ case mttl of+ Nothing -> return $ (pack "Untitled", Nothing)+ (Just ttlSlug) -> return ttlSlug+ html <- unXMLGenT $ <a href=(clckShowURL (ViewPageSlug pid (toSlug ttl slug)) [])><% ttl %></a>+ return $ B.fromString $ concat $ lines $ renderAsHTML html
+ Clckwrks/Page/Types.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies #-}+module Clckwrks.Page.Types where++import Clckwrks.Markup.HsColour (hscolour)+import Clckwrks.Markup.Markdown (markdown)+import Clckwrks.Types (Trust(..))+import Control.Applicative ((<$>), optional)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Aeson (ToJSON(..), FromJSON(..))+import Data.Char (ord, toLower, isAlphaNum)+import Data.Data (Data, Typeable)+import Data.Maybe (fromMaybe)+import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.UUID (UUID)+import Data.UUID.V5 (generateNamed, namespaceOID)+import Happstack.Auth (UserId(..))+import Web.Routes (PathInfo(..), anySegment)+import System.Random (randomIO)+++$(deriveSafeCopy 0 'base ''UUID)++instance PathInfo PageId where+ toPathSegments (PageId i) = toPathSegments i+ fromPathSegments = PageId <$> fromPathSegments++newtype PageId = PageId { unPageId :: Integer }+ deriving (Eq, Ord, Show, Read, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageId)++instance ToJSON PageId where+ toJSON (PageId i) = toJSON i+instance FromJSON PageId where+ parseJSON n = PageId <$> parseJSON n++data PreProcessor+ = HsColour+ | Markdown+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PreProcessor)++-- $(deriveJSON id ''PreProcessor)++runPreProcessors :: (MonadIO m) => [PreProcessor] -> Trust -> Text -> m (Either Text Text)+runPreProcessors [] _ txt = return (Right txt)+runPreProcessors (p:ps) trust txt =+ do e <- runPreProcessor p trust txt+ case e of+ (Left e) -> return (Left e)+ (Right txt') -> runPreProcessors ps trust txt'++runPreProcessor :: (MonadIO m) => PreProcessor -> Trust -> Text -> m (Either Text Text)+runPreProcessor pproc trust txt =+ do let f = case pproc of+ Markdown -> markdown Nothing trust+ HsColour -> hscolour Nothing+ f txt++data Markup_001+ = Markup_001 { preProcessors_001 :: [PreProcessor]+ , markup_001 :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''Markup_001)++data Markup+ = Markup { preProcessors :: [PreProcessor]+ , markup :: Text+ , trust :: Trust+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''Markup)++instance Migrate Markup where+ type MigrateFrom Markup = Markup_001+ migrate (Markup_001 pp mu) = Markup pp mu Trusted++data PublishStatus+ = Draft+ | Revoked+ | Published+ | Scheduled+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PublishStatus)++data PageKind+ = PlainPage+ | Post+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PageKind)++data Page_001+ = Page_001 { pageId_001 :: PageId+ , pageTitle_001 :: Text+ , pageSrc_001 :: Markup+ , pageExcerpt_001 :: Maybe Markup+ , pageDate_001 :: Maybe UTCTime+ , pageStatus_001 :: PublishStatus+ , pageKind_001 :: PageKind+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''Page_001)++data Page_002+ = Page_002 { pageId_002 :: PageId+ , pageAuthor_002 :: UserId+ , pageTitle_002 :: Text+ , pageSrc_002 :: Markup+ , pageExcerpt_002 :: Maybe Markup+ , pageDate_002 :: UTCTime+ , pageUpdated_002 :: UTCTime+ , pageStatus_002 :: PublishStatus+ , pageKind_002 :: PageKind+ , pageUUID_002 :: UUID+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''Page_002)++instance Migrate Page_002 where+ type MigrateFrom Page_002 = Page_001+ migrate (Page_001 pi pt ps pe pd pst pk) =+ (Page_002 pi (UserId 1) pt ps pe (fromMaybe epoch pd) (fromMaybe epoch pd) pst pk $ generateNamed namespaceOID (map (fromIntegral . ord) (show pi ++ show ps)))+ where+ epoch = posixSecondsToUTCTime 0++newtype Slug = Slug { unSlug :: Text }+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''Slug)++instance PathInfo Slug where+ toPathSegments (Slug txt) = [txt]+ fromPathSegments = Slug <$> anySegment++-- NOTE: this instance will cause faulty behavior if the Maybe Slug is not at the end of the URL+instance PathInfo (Maybe Slug) where+ toPathSegments (Just slug) = toPathSegments slug+ fromPathSegments = optional $ fromPathSegments++slugify :: Text -> Slug+slugify txt = Slug $ Text.dropWhileEnd (=='-') $ Text.map (\c -> if isAlphaNum c then (toLower c) else '-') txt++toSlug :: Text -> Maybe Slug -> Slug+toSlug txt slug = fromMaybe (slugify txt) slug++data Page+ = Page { pageId :: PageId+ , pageAuthor :: UserId+ , pageTitle :: Text+ , pageSlug :: Maybe Slug+ , pageSrc :: Markup+ , pageExcerpt :: Maybe Markup+ , pageDate :: UTCTime+ , pageUpdated :: UTCTime+ , pageStatus :: PublishStatus+ , pageKind :: PageKind+ , pageUUID :: UUID+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 3 'extension ''Page)++instance Migrate Page where+ type MigrateFrom Page = Page_002+ migrate (Page_002 pi pa pt ps pe pd pu pst pk puu) =+ (Page pi pa pt Nothing ps pe pd pu pst pk puu)++instance Indexable Page where+ empty = ixSet [ ixFun ((:[]) . pageId)+ , ixFun ((:[]) . pageDate)+ , ixFun ((:[]) . pageKind)+ , ixFun ((:[]) . pageDate)+ , ixFun ((:[]) . pageStatus)+ ]++type Pages = IxSet Page++data FeedConfig = FeedConfig+ { feedUUID :: UUID -- ^ UUID which identifies this feed. Should probably never change+-- , feedCategory :: Set Text+ , feedTitle :: Text+ , feedLink :: Text+ , feedAuthorName :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''FeedConfig)++initialFeedConfig :: IO FeedConfig+initialFeedConfig =+ do uuid <- randomIO+ return $ FeedConfig { feedUUID = uuid+ , feedTitle = fromString "Untitled Feed"+ , feedLink = fromString ""+ , feedAuthorName = fromString "Anonymous"+ }
+ Clckwrks/Plugin.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-}+module Clckwrks.Plugin where++import Clckwrks+import Clckwrks.Admin.Route (routeAdmin)+import Clckwrks.BasicTemplate (basicTemplate)+import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..))+import Clckwrks.Page.Atom (handleAtomFeed)+import Clckwrks.ProfileData.Route (routeProfileData)+import Clckwrks.Page.PreProcess (pageCmd)+import Clckwrks.Server (checkAuth)+import Control.Monad.State (MonadState(get))+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Happstack.Auth (handleAuthProfile)+import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)+import Network.URI (unEscapeString)+import System.FilePath ((</>), makeRelative, splitDirectories)+import Web.Plugins.Core (Plugin(..), addHandler, getTheme, getPluginRouteFn, initPlugin)+import Paths_clckwrks (getDataDir)++themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>+ ClckPlugins+ -> Text+ -> headers+ -> body+ -> ClckT ClckURL (ServerPartT IO) Response+themeTemplate plugins ttl hdrs bdy =+ do mTheme <- getTheme plugins+ case mTheme of+ Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: Text)+ (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme ttl hdrs bdy)+++clckHandler :: (ClckURL -> [(Text, Maybe Text)] -> Text)+ -> ClckPlugins+ -> [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++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+ ttl <- getPageTitle+ bdy <- getPageContent+ themeTemplate (plugins cs) ttl () bdy+ else do notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid))++ (Blog) ->+ do p <- plugins <$> get+ mTheme <- getTheme p+ case mTheme of+ Nothing -> escape $ internalServerError $ toResponse $ ("No theme package is loaded." :: Text)+ (Just theme) -> fmap toResponse $ unXMLGenT $ themeBlog theme++ AtomFeed ->+ do handleAtomFeed++ (ThemeData fp') ->+ do p <- plugins <$> get+ mTheme <- getTheme p+ case mTheme of+ Nothing -> notFound $ toResponse ("No theme package is loaded." :: Text)+ (Just theme) ->+ do fp <- liftIO $ themeDataDir theme+ let fp'' = makeRelative "/" (unEscapeString fp')+ if not (isSafePath (splitDirectories fp''))+ then notFound (toResponse ())+ else serveFile (guessContentTypeM mimeTypes) (fp </> "data" </> fp'')++ (PluginData plugin fp') ->+ do pp <- liftIO getDataDir+ 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 :: ClckPlugins+ -> IO (Maybe Text)+clckInit plugins =+ do (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ addPreProc plugins (pageCmd clckShowFn)+ addHandler plugins (pluginName clckPlugin) (clckHandler clckShowFn)+ return Nothing+++clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ([TL.Text -> ClckT ClckURL IO TL.Text])+clckPlugin = Plugin+ { pluginName = "clck"+ , pluginInit = clckInit+ , pluginDepends = []+ , pluginToPathInfo = toPathInfo+ , pluginPostHook = return ()+ }++plugin :: ClckPlugins+ -> Text+ -> IO (Maybe Text)+plugin plugins baseURI =+ initPlugin plugins baseURI clckPlugin
+ Clckwrks/ProfileData/API.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}+module Clckwrks.ProfileData.API+ ( getProfileData+ , getUsername+ , whoami+ ) where++import Clckwrks.Acid (Acid(..))+import Clckwrks.Monad+import Clckwrks.ProfileData.Acid+import Clckwrks.ProfileData.Types+import Control.Applicative ((<$>))+import Control.Monad.State (get)+import Data.Text (Text)+import Happstack.Auth (UserId(..))++getProfileData :: UserId -> Clck url (Maybe ProfileData)+getProfileData uid = query (GetProfileData uid)++getUsername :: UserId -> Clck url (Maybe Text)+getUsername uid =+ query (GetUsername uid)++whoami :: Clck url (Maybe UserId)+whoami =+ do -- Acid{..} <- acidState <$> get+ getUserId+
+ Clckwrks/ProfileData/Acid.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, RecordWildCards, TypeFamilies #-}+module Clckwrks.ProfileData.Acid+ ( ProfileDataState(..)+ , initialProfileDataState+ , ProfileDataError(..)+ , profileDataErrorStr+ , SetProfileData(..)+ , GetProfileData(..)+ , NewProfileData(..)+ , GetUsername(..)+ , GetUserIdUsernames(..)+ , HasRole(..)+ , AddRole(..)+ , RemoveRole(..)+ , UsernameForId(..)+ ) where++import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), Username(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)+import Data.Acid (Update, Query, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx, toList)+import Data.SafeCopy (base, deriveSafeCopy)+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as Text+import Happstack.Auth (UserId(..))++data ProfileDataState = ProfileDataState+ { profileData :: IxSet ProfileData+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 1 'base ''ProfileDataState)++initialProfileDataState :: ProfileDataState+initialProfileDataState = ProfileDataState { profileData = empty }++data ProfileDataError+ = UsernameAlreadyInUse+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''ProfileDataError)++profileDataErrorStr :: ProfileDataError -> String+profileDataErrorStr UsernameAlreadyInUse = "Username already in use."++checkInvariants :: ProfileDataState -> ProfileData -> Maybe ProfileDataError+checkInvariants pds@ProfileDataState{..} pd =+ case getOne $ profileData @= (Username $ username pd) of+ (Just existingPd)+ | ((username existingPd) == (username pd)) &&+ ((username pd) /= Text.pack "Anonymous") &&+ (not $ Text.null (username pd)) ->+ (Just UsernameAlreadyInUse)+ _ ->+ Nothing+++setProfileData :: ProfileData+ -> Update ProfileDataState (Maybe ProfileDataError)+setProfileData pd =+ do pds@(ProfileDataState{..}) <- get+ case checkInvariants pds pd of+ (Just err) -> return (Just err)+ Nothing ->+ do put $ pds { profileData = updateIx (dataFor pd) pd profileData }+ return Nothing++++getProfileData :: UserId+ -> Query ProfileDataState (Maybe ProfileData)+getProfileData uid =+ do ProfileDataState{..} <- ask+ return $ getOne $ profileData @= uid++updateProfileData :: ProfileData+ -> Update ProfileDataState ()+updateProfileData pd =+ do ps <- get+ put $ ps { profileData = updateIx (dataFor pd) pd (profileData ps) }++modifyProfileData :: (ProfileData -> ProfileData)+ -> UserId+ -> Update ProfileDataState ()+modifyProfileData fn uid =+ do ps@(ProfileDataState {..}) <- get+ case getOne $ profileData @= uid of+ Nothing -> return ()+ (Just pd) ->+ do let pd' = fn pd+ put ps { profileData = updateIx (dataFor pd') pd' profileData }++-- | create the profile data, but only if it is missing+newProfileData :: ProfileData+ -> Update ProfileDataState ProfileData+newProfileData pd =+ do pds@(ProfileDataState {..}) <- get+ case getOne (profileData @= (dataFor pd)) of+ Nothing -> do put $ pds { profileData = updateIx (dataFor pd) pd profileData }+ return pd+ (Just pd') -> return pd'++getUsername :: UserId+ -> Query ProfileDataState (Maybe Text)+getUsername uid =+ fmap username <$> getProfileData uid++-- | get all the users+getUserIdUsernames :: Query ProfileDataState [(UserId, Text)]+getUserIdUsernames =+ do pds <- profileData <$> ask+ return $ map (\pd -> (dataFor pd, username pd)) (toList pds)++hasRole :: UserId+ -> Set Role+ -> Query ProfileDataState Bool+hasRole uid role =+ do mp <- getProfileData uid+ case mp of+ Nothing -> return False+ (Just profile) ->+ return (not $ Set.null $ role `Set.intersection` roles profile)++addRole :: UserId+ -> Role+ -> Update ProfileDataState ()+addRole uid role =+ modifyProfileData fn uid+ where+ fn profileData = profileData { roles = Set.insert role (roles profileData) }++removeRole :: UserId+ -> Role+ -> Update ProfileDataState ()+removeRole uid role =+ modifyProfileData fn uid+ where+ fn profileData = profileData { roles = Set.delete role (roles profileData) }++usernameForId :: UserId+ -> Query ProfileDataState (Maybe Text)+usernameForId uid =+ do ProfileDataState{..} <- ask+ case getOne $ profileData @= uid of+ Nothing -> return Nothing+ (Just pd) -> return $ Just $ username pd++dataForUsername :: Text -- ^ username+ -> Query ProfileDataState (Maybe ProfileData)+dataForUsername uname =+ do ProfileDataState{..} <- ask+ return $ getOne $ profileData @= (Username uname)++$(makeAcidic ''ProfileDataState+ [ 'setProfileData+ , 'getProfileData+ , 'newProfileData+ , 'getUsername+ , 'getUserIdUsernames+ , 'hasRole+ , 'addRole+ , 'removeRole+ , 'usernameForId+ , 'dataForUsername+ ])
+ Clckwrks/ProfileData/EditProfileData.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.ProfileData.EditProfileData where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+import Data.Text (Text, pack)+import Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import Happstack.Auth (UserId)+import Text.Reform ((++>), transformEitherM)+import Text.Reform.HSP.Text (form, inputText, inputSubmit, label, fieldset, ol, li)+import Text.Reform.Happstack (reform)++-- FIXME: this currently uses the admin template. Which is sort of right, and sort of not.++editProfileDataPage :: ProfileDataURL -> Clck ProfileDataURL Response+editProfileDataPage here =+ do mUid <- getUserId+ case mUid of+ Nothing -> internalServerError $ toResponse $ "Unable to retrieve your userid"+ (Just uid) ->+ do mpd <- query (GetProfileData uid)+ case mpd of+ Nothing ->+ internalServerError $ toResponse $ "Missing profile data for " ++ show uid+ (Just pd) ->+ do action <- showURL here+ template "Edit Profile Data" () $+ <%>+ <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>+ </%>+ where+ updated :: () -> Clck ProfileDataURL Response+ updated () =+ do seeOtherURL here++profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL ()+profileDataFormlet pd@ProfileData{..} =+ ((,) <$> (li $ label "username:" ) ++> (li $ inputText username)+ <*> (li $ label" email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))+ <* inputSubmit (pack "update"))+ `transformEitherM` updateProfileData+ where+ updateProfileData :: (Text, Text) -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData (usrnm, eml) =+ if Text.null usrnm+ then do return (Left EmptyUsername)+ else do let newPd = pd { username = usrnm+ , email = if Text.null eml then Nothing else (Just eml)+ }+ merr <- update (SetProfileData newPd)+ case merr of+ Nothing -> return $ Right ()+ (Just err) -> return $ Left (PDE err)
+ Clckwrks/ProfileData/EditProfileDataFor.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.ProfileData.EditProfileDataFor where++import Clckwrks+import Clckwrks.Admin.Template (template)+import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)+import Data.Maybe (fromMaybe)+import Data.Set as Set+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Happstack.Auth (UserId)+import Text.Reform ((++>), transformEitherM)+import Text.Reform.Happstack (reform)+import Text.Reform.HSP.Text (inputCheckboxes, inputText, label, inputSubmit, fieldset, ol, li, form)++editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response+editProfileDataForPage here uid =+ do mpd <- query (GetProfileData uid)+ case mpd of+ Nothing ->+ do notFound ()+ template "Edit Profile Data" () $+ <p>No profile data for <% show uid %>.</p>+ (Just pd) ->+ do action <- showURL here+ template "Edit Profile Data" () $+ <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %>++ where+ updated :: () -> Clck ProfileDataURL Response+ updated () =+ do seeOtherURL here++profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL ()+profileDataFormlet pd@ProfileData{..} =+ (fieldset $+ ol $+ ((,,) <$> (li $ label "username:") ++> (li $ inputText username)+ <*> (li $ label "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))+ <*> (li $ label "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles))+ <* inputSubmit (pack "update")+ )+ ) `transformEitherM` updateProfileData+ where+ updateProfileData :: (Text, Text, [Role]) -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData (usrnm, eml, roles') =+ if Text.null usrnm+ then do return (Left EmptyUsername)+ else do let newPd = pd { username = usrnm+ , email = if Text.null eml then Nothing else (Just eml)+ , roles = Set.fromList roles'+ }+ merr <- update (SetProfileData newPd)+ case merr of+ Nothing -> return $ Right ()+ (Just err) -> return $ Left (PDE err)
+ Clckwrks/ProfileData/Route.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RecordWildCards #-}+module Clckwrks.ProfileData.Route where++import Clckwrks+import Clckwrks.ProfileData.Acid+import Clckwrks.ProfileData.EditProfileData (editProfileDataPage)+import Clckwrks.ProfileData.EditProfileDataFor (editProfileDataForPage)+import Clckwrks.ProfileData.URL (ProfileDataURL(..))+import Clckwrks.ProfileData.Types+import Control.Monad.State (get)+import Data.Set (singleton)+import Data.Text (Text)++routeProfileData :: ProfileDataURL -> Clck ProfileDataURL Response+routeProfileData url =+ case url of+ CreateNewProfileData ->+ do mUserId <- getUserId+ case mUserId of+ Nothing -> internalServerError $ toResponse $ "not logged in."+ (Just userId) ->+ do let profileData = emptyProfileData { dataFor = userId+ , roles = singleton Visitor+ }+ update (NewProfileData profileData)+ seeOtherURL EditProfileData+ EditProfileData ->+ do editProfileDataPage url+ EditProfileDataFor u ->+ do editProfileDataForPage url u+
+ Clckwrks/ProfileData/Types.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+module Clckwrks.ProfileData.Types+ ( ProfileData(..)+ , Role(..)+ , emptyProfileData+ , Username(..)+ ) where++import Happstack.Auth (UserId(..))+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable(..), ixSet, ixFun)+import Data.IxSet.Ix (Ix)+import Data.Map (Map, empty)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.Set (Set, empty)+import Data.Text (Text, empty)+import Data.Typeable (Typeable)++data Role_001+ = Administrator_001+ | Visitor_001+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+$(deriveSafeCopy 1 'base ''Role_001)++data Role+ = Administrator+ | Visitor+ | Moderator+ | Editor+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)+$(deriveSafeCopy 2 'extension ''Role)++instance Migrate Role where+ type MigrateFrom Role = Role_001+ migrate Administrator_001 = Administrator+ migrate Visitor_001 = Visitor+++data ProfileData = ProfileData+ { dataFor :: UserId+ , username :: Text+ , email :: Maybe Text+ , roles :: Set Role+ , attributes :: Map Text Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 1 'base ''ProfileData)++emptyProfileData :: ProfileData+emptyProfileData = ProfileData+ { dataFor = UserId 0+ , username = Data.Text.empty+ , email = Nothing+ , roles = Data.Set.empty+ , attributes = Data.Map.empty+ }++newtype Username = Username { unUsername :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance Indexable ProfileData where+ empty = ixSet [ ixFunS dataFor+ , ixFunS $ Username . username+ ]+ where+ ixFunS :: (Ord b, Typeable b) => (a -> b) -> Ix a+ ixFunS f = ixFun $ \a -> [f a]
+ Clckwrks/ProfileData/URL.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}+module Clckwrks.ProfileData.URL where++import Data.Data (Data, Typeable)+import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy)+import Happstack.Auth (UserId)+import Web.Routes.TH (derivePathInfo)++data ProfileDataURL+ = CreateNewProfileData+ | EditProfileData+ | EditProfileDataFor UserId+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(derivePathInfo ''ProfileDataURL)+$(deriveSafeCopy 1 'base ''ProfileDataURL)
+ Clckwrks/Server.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, RecordWildCards #-}+module Clckwrks.Server where++import Clckwrks+import Clckwrks.BasicTemplate (basicTemplate)+import Clckwrks.Admin.Route (routeAdmin)+import Clckwrks.Admin.Template (defaultAdminMenu)+import Clckwrks.Monad (ClckwrksConfig(..))+import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..))+import Clckwrks.Page.Atom (handleAtomFeed)+import Clckwrks.Page.PreProcess (pageCmd)+import Clckwrks.ProfileData.Route (routeProfileData)+import Clckwrks.ProfileData.Types (Role(..))+import Clckwrks.ProfileData.URL (ProfileDataURL(..))+import Control.Arrow (second)+import Control.Concurrent.STM (atomically, newTVar)+import Control.Monad.State (get, evalStateT)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.UUID as UUID+import Happstack.Auth (handleAuthProfile)+import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)+import Network.URI (unEscapeString)+import System.FilePath ((</>), makeRelative, splitDirectories)+import Web.Routes.Happstack (implSite)+import Web.Plugins.Core (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve)+import qualified Paths_clckwrks as Clckwrks++withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b+withClckwrks cc action =+ withPlugins cc [] $ \plugins ->+ withAcid (fmap (\top -> top </> "_state") (clckTopDir cc)) $ \acid ->+ do u <- atomically $ newTVar 0+ let clckState = ClckState { acidState = acid+ , currentPage = PageId 0+ , uniqueId = u+ , adminMenus = []+ , enableAnalytics = clckEnableAnalytics cc+ , plugins = plugins+ }+ action clckState++simpleClckwrks :: ClckwrksConfig -> IO ()+simpleClckwrks cc =+ withClckwrks cc $ \clckState ->+ do (clckState', cc') <- (clckInitHook cc) (calcBaseURI 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 sequence_ hooks+ dm <- defaultAdminMenu+ mapM_ addAdminMenu dm+ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'')+ where+ handlers cc clckState =+ do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6))+ msum $+ [ jsHandlers cc+ , dir "favicon.ico" $ notFound (toResponse ())+ , dir "static" $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing []+ , nullDir >> seeOther ("/clck/view-page/1" :: String) (toResponse ())+ , clckSite cc clckState+ ]++jsHandlers :: (Happstack m) => ClckwrksConfig -> m Response+jsHandlers c =+ msum [ dir "jquery" $ serveDirectory DisableBrowsing [] (clckJQueryPath c)+ , dir "jquery-ui" $ serveDirectory DisableBrowsing [] (clckJQueryUIPath c)+ , dir "jstree" $ serveDirectory DisableBrowsing [] (clckJSTreePath c)+ , dir "json2" $ serveDirectory DisableBrowsing [] (clckJSON2Path c)+ ]++checkAuth :: (Happstack m, Monad m) => ClckURL -> ClckT ClckURL m ClckURL+checkAuth url =+ case url of+ ViewPage{} -> return url+ ViewPageSlug{} -> return url+ Blog{} -> return url+ AtomFeed{} -> return url+ ThemeData{} -> return url+ PluginData{} -> return url+ Admin{} -> requiresRole (Set.singleton Administrator) url+ Auth{} -> return url+ Profile EditProfileData{} -> requiresRole (Set.fromList [Administrator, Visitor]) url+ Profile EditProfileDataFor{} -> requiresRole (Set.fromList [Administrator]) url+ Profile CreateNewProfileData -> return url++clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response+clckSite cc clckState =+ do (Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck")+ evalClckT clckShowFn clckState (pluginsHandler (plugins clckState))++pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) =>+ Plugins theme (m Response) hook config ppm+ -> 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 ())
+ Clckwrks/Types.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+module Clckwrks.Types where++import Data.Data (Data, Typeable)+import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)+import Data.Text as T++-- | at present this is only used by the menu editor+newtype Prefix = Prefix { prefixText :: T.Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy)++data Trust+ = Trusted -- ^ used when the author can be trusted (sanitization is not performed)+ | Untrusted -- ^ used when the author can not be trusted (sanitization is performed)+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 0 'base ''Trust)
+ Clckwrks/URL.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+module Clckwrks.URL+ ( ClckURL(..)+ , AdminURL(..)+ , AuthURL(..)+ , ProfileURL(..)+ , AuthProfileURL(..)+ , ProfileDataURL(..)+ ) where++import Clckwrks.Admin.URL (AdminURL(..))+import Clckwrks.Page.Acid (PageId(..))+import Clckwrks.ProfileData.URL (ProfileDataURL(..))+import Clckwrks.Page.Types (Slug(..))+import Control.Applicative ((<$>))+import Data.Data (Data, Typeable)+import Data.SafeCopy (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension)+import Data.Text (Text)+import Happstack.Auth (AuthURL(..), ProfileURL(..), AuthProfileURL(..), UserId)+import Happstack.Auth.Core.AuthURL (OpenIdURL, AuthMode, OpenIdProvider)+import Web.Routes.TH (derivePathInfo)++data ClckURL_1+ = ViewPage_1 PageId+ | Blog_1+ | AtomFeed_1+ | ThemeData_1 FilePath+ | PluginData_1 Text FilePath+ | Admin_1 AdminURL+ | Profile_1 ProfileDataURL+ | Auth_1 AuthProfileURL+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 1 'base ''ClckURL_1)++data ClckURL+ = ViewPage PageId+ | ViewPageSlug PageId Slug+ | Blog+ | AtomFeed+ | ThemeData FilePath+ | PluginData Text FilePath+ | Admin AdminURL+ | Profile ProfileDataURL+ | Auth AuthProfileURL+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 2 'extension ''ClckURL)++instance Migrate ClckURL where+ type MigrateFrom ClckURL = ClckURL_1+ migrate (ViewPage_1 pid) = ViewPage pid+ migrate Blog_1 = Blog+ migrate AtomFeed_1 = AtomFeed+ migrate (ThemeData_1 fp) = ThemeData fp+ migrate (PluginData_1 t f) = PluginData t f+ migrate (Admin_1 u) = Admin u+ migrate (Profile_1 pdu) = Profile pdu+ migrate (Auth_1 apu) = Auth apu++-- TODO: move upstream+$(deriveSafeCopy 1 'base ''AuthURL)+$(deriveSafeCopy 1 'base ''ProfileURL)+$(deriveSafeCopy 1 'base ''AuthProfileURL)+$(deriveSafeCopy 1 'base ''OpenIdURL)+$(deriveSafeCopy 1 'base ''AuthMode)+$(deriveSafeCopy 1 'base ''OpenIdProvider)+++$(derivePathInfo ''ClckURL)
+ Clckwrks/Unauthorized.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.Unauthorized+ ( unauthorizedPage+ ) where++import Control.Applicative ((<$>))+import HSP+import Happstack.Server (Happstack, Response, ToMessage, toResponse, unauthorized)+import qualified HSX.XMLGenerator (XMLType)++unauthorizedPage ::+ ( Happstack m+ , XMLGenerator m+ , EmbedAsChild m msg+ , ToMessage (XMLType m)+ ) => msg -> m Response+unauthorizedPage msg =+ do unauthorized ()+ toResponse <$> (unXMLGenT $+ <html>+ <head>+ <title>Unauthorized</title>+ </head>+ <body>+ <div>+ <h1>Unauthorized</h1>+ <p><% msg %></p>+ </div>+ </body>+ </html>)
+ HSP/HTMLBuilder.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- |+-- Module : HSP.HTML+-- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se+-- Stability : experimental+-- Portability : Haskell 98+--+-- Attempt to render XHTML as well-formed HTML 4.01:+--+-- 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>+--+-- 2. the end tag is forbidden for some elements, for these we:+--+-- * render only the open tag, e.g., \<br\>+--+-- * throw an error if the tag contains children+--+-- 3. optional end tags are always rendered+--+-- Currently no validation is performed.+-----------------------------------------------------------------------------+module HSP.HTMLBuilder (+ Style(..)+ -- * Functions+ , renderAsHTML+ , htmlEscapeChars+ ) where++import Data.List+import Data.Monoid (mappend, mconcat, mempty)+import Data.Text.Lazy (unpack)+import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText)+import HSP.XML+import HSP.XML.PCDATA(escaper)++-- | Pretty-prints HTML values.+--+-- Error Handling:+--+-- Some tags (such as img) can not contain children in HTML. However,+-- there is nothing to stop the caller from passing in XML which+-- contains an img tag with children. There are three basic ways to+-- handle this:+--+-- 1. drop the bogus children silently+--+-- 2. call 'error' \/ raise an exception+--+-- 3. render the img tag with children -- even though it is invalid+--+-- Currently we are taking approach #3, since no other attempts to+-- validate the data are made in this function. Instead, you can run+-- the output through a full HTML validator to detect the errors.+--+-- #1 seems like a poor choice, since it makes is easy to overlook the+-- fact that data went missing.+--+-- We could raising errors, but you have to be in the IO monad to+-- catch them. Also, you have to use evaluate if you want to check for+-- errors. This means you can not start sending the page until the+-- whole page has been rendered. And you have to store the whole page+-- in RAM at once. Similar problems occur if we return Either+-- instead. We mostly care about catching errors and showing them in+-- the browser during testing, so perhaps this can be configurable.+--+-- Another solution would be a compile time error if an empty-only+-- tag contained children.+--+-- FIXME: also verify that the domain is correct+--+-- FIXME: what to do if a namespace is encountered++renderAsHTML :: Style -> XML -> Builder+renderAsHTML style xml = renderAsHTML' style 0 xml++data TagType = Open | Close++data Style = Compact | Expanded++renderAsHTML' :: Style -> Int -> XML -> Builder+renderAsHTML' _ _ (CDATA needsEscape cd) = fromString (if needsEscape then (escaper htmlEscapeChars cd) else cd)++renderAsHTML' style n elm@(Element name@(Nothing,nm) attrs children)+ | nm == "area" = renderTagEmpty children+ | nm == "base" = renderTagEmpty children+ | nm == "br" = renderTagEmpty children+ | nm == "col" = renderTagEmpty children+ | nm == "hr" = renderTagEmpty children+ | nm == "img" = renderTagEmpty children+ | nm == "input" = renderTagEmpty children+ | nm == "link" = renderTagEmpty children+ | nm == "meta" = renderTagEmpty children+ | nm == "param" = renderTagEmpty children+ | nm == "script" = renderElement style n (Element name attrs (map asCDATA children))+ | nm == "style" = renderElement style n (Element name attrs (map asCDATA children))+ where+ renderTagEmpty [] = renderTag style Open n name attrs+ renderTagEmpty _ = renderElement style n elm -- this case should not happen in valid HTML+ -- for and script\/style, render text in element as CDATA not PCDATA+ asCDATA :: XML -> XML+ asCDATA (CDATA _ cd) = (CDATA False cd)+ asCDATA o = o -- this case should not happen in valid HTML+renderAsHTML' style n e = renderElement style n e++renderElement :: Style -> Int -> XML -> Builder+renderElement style n (Element name attrs children) =+ let open = renderTag style Open n name attrs+ cs = renderChildren n children+ close = renderTag style Close n name []+ in mconcat [open, cs, close]+ where renderChildren :: Int -> Children -> Builder+ renderChildren n' cs = mconcat $ map (renderAsHTML' style (n'+2)) cs+renderElement _ _ _ = error "internal error: renderElement only suports the Element constructor."+++renderTag :: Style -> TagType -> Int -> Name -> Attributes -> Builder+renderTag style typ n name attrs =+ let (start,end) = case typ of+ Open -> (singleton '<' , singleton '>')+ Close -> (fromString "</", singleton '>')+ nam = showName name+ as = renderAttrs attrs+ in mconcat [start, nam, as, end]++ where renderAttrs :: Attributes -> Builder+ renderAttrs [] = nl+ renderAttrs attrs' = mconcat [singleton ' ', ats, nl]+ where ats = mconcat $ intersperse (singleton ' ') $ fmap renderAttr attrs'++ renderAttr :: Attribute -> Builder+ renderAttr (MkAttr (nam, (Value needsEscape val))) =+ mconcat [ showName nam, singleton '=', renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)]++ renderAttrVal :: String -> Builder+ renderAttrVal s =+ mconcat [singleton '\"', fromString s, singleton '\"']++ showName (Nothing, s) = fromString s+ showName (Just d, s) = mconcat [fromString d, singleton ':', fromString s]++ nl =+ case style of+ Compact -> mempty+ Expanded -> singleton '\n' `mappend` (fromString $ replicate n ' ')++-- This list should be extended.+htmlEscapeChars :: [(Char, String)]+htmlEscapeChars = [+ ('&', "amp" ),+ ('\"', "quot" ),+ ('<', "lt" ),+ ('>', "gt" )+ ]
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jeremy Shaw 2011++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.
+ Setup.hs view
@@ -0,0 +1,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ clckwrks.cabal view
@@ -0,0 +1,119 @@+Name: clckwrks+Version: 0.13.0+Synopsis: A secure, reliable content management system (CMS) and blogging platform+Description: clckwrks (pronounced, clockworks) aims to compete+ directly with popular PHP-based blogging and CMS+ platforms. Clckwrks aims to support one-click+ installation of plugins and themes. End users+ should be able to use it with zero Haskell+ knowledge. Haskell developers can extend clckwrks+ by creating new plugins or by building sites+ around the existing clckwrks core and plugins.+ .+ clckwrks is still in very early development. Not all features have been implement yet.+Homepage: http://www.clckwrks.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: Jeremy Shaw <jeremy@n-heptane.com>+Copyright: 2012 SeeReason Partners LLC, Jeremy Shaw+Stability: Experimental+Category: Clckwrks+Build-type: Custom+Cabal-version: >=1.6+Data-Files:+ static/admin.css++source-repository head+ type: darcs+ subdir: clckwrks+ location: http://hub.darcs.net/stepcut/clckwrks++Library+ Build-tools: trhsx+ Exposed-modules: Clckwrks+ Clckwrks.Acid+ Clckwrks.Admin.Template+ Clckwrks.Admin.URL+ Clckwrks.Admin.Console+ Clckwrks.Admin.Route+ Clckwrks.Admin.NewPage+ Clckwrks.Admin.Pages+ Clckwrks.Admin.EditPage+ Clckwrks.Admin.EditFeedConfig+ Clckwrks.Admin.EditSettings+ Clckwrks.Admin.PreviewPage+ Clckwrks.BasicTemplate+ Clckwrks.GetOpts+ Clckwrks.IOThread+ Clckwrks.Monad+ Clckwrks.Server+ Clckwrks.Markup.HsColour+ Clckwrks.Markup.Markdown+ Clckwrks.Menu.Acid+ Clckwrks.Menu.API+ Clckwrks.Menu.Edit+ Clckwrks.Menu.Types+ Clckwrks.Page.Types+ Clckwrks.Page.Acid+ Clckwrks.Page.API+ Clckwrks.Page.Atom+ Clckwrks.Page.PreProcess+ Clckwrks.Plugin+ Clckwrks.ProfileData.URL+ Clckwrks.ProfileData.Route+ Clckwrks.ProfileData.Types+ Clckwrks.ProfileData.Acid+ Clckwrks.ProfileData.API+ Clckwrks.ProfileData.EditProfileData+ Clckwrks.ProfileData.EditProfileDataFor+ Clckwrks.Types+ Clckwrks.Unauthorized+ Clckwrks.URL+ HSP.HTMLBuilder+ Paths_clckwrks++ Build-depends:+ acid-state >= 0.7 && < 0.9,+ aeson >= 0.5 && < 0.7,+ attoparsec == 0.10.*,+ base < 5,+ blaze-html == 0.5.*,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.4 && < 0.6,+ directory >= 1.1 && < 1.3,+ filepath >= 1.2 && < 1.4,+ happstack-authenticate == 0.9.*,+ happstack-hsp == 7.1.*,+ happstack-server >= 7.0 && < 7.2,+ hsp == 0.7.*,+ hsx == 0.10.*,+ hsx-jmacro == 7.1.*,+ ixset == 1.0.*,+ jmacro == 0.5.*,+ mtl >= 2.0 && < 2.3,+ network >= 2.3 && < 2.5,+ old-locale == 1.0.*,+ process >= 1.0 && < 1.2,+-- plugins-auto == 0.0.1.1,+ random == 1.0.*,+ reform == 0.1.*,+ reform-happstack == 0.1.*,+ reform-hsp >= 0.1.1 && < 0.2,+ safecopy >= 0.6,+ stm >= 2.2 && <2.5,+ tagsoup == 0.12.*,+ text == 0.11.*,+ time >= 1.2 && <1.5,+ uuid == 1.2.*,+ unordered-containers >= 0.1 && < 0.3,+ utf8-string == 0.3.*,+ vector >= 0.9,+ web-plugins == 0.1.*,+ web-routes,+ web-routes-happstack,+ web-routes-hsp,+ web-routes-th >= 0.21,+ xss-sanitize == 0.3.*++ -- Build-tools: trhsx
+ static/admin.css view
@@ -0,0 +1,79 @@+body+{+ margin: 0;+ padding: 0;+}++form fieldset+{+ border: none;+}++form ol+{+ list-style-type: none;+}++/* admin console */++#admin-sidebar+{+ width: 200px;+ position: absolute;+ top: 0;+ left: 0;+ padding: 0;+ border-right: 1px solid black;+ height: 100%;+}++#admin-body+{+ position: absolute;+ top: 0;+ left: 210px;+}++ul#admin-menu+{+ list-style-type: none;+ padding: 0;+ margin: 0;++}++#admin-menu ul+{+ list-style-type: none;+ padding: 0;+ margin: 0;+}++.admin-menu-link+{+ border-bottom: 1px dotted #ddd;+ padding-left: 1em;+}++#admin-menu a+{+ text-decoration: none;+ color: black;+}++#admin-menu-links li:hover+{+ background: #ddd;+}+++.admin-menu-category-title+{++ display: block;+ font-weight: bold;+ color: white;+ background: gray;+ font-size: 1.1em;+ padding-left: 1em;+}