clckwrks 0.14.2 → 0.16.2
raw patch · 35 files changed
+922/−1840 lines, 35 filesdep +happstack-server-tlsdep ~blaze-htmldep ~happstack-authenticate
Dependencies added: happstack-server-tls
Dependency ranges changed: blaze-html, happstack-authenticate
Files
- Clckwrks.hs +2/−6
- Clckwrks/Acid.hs +57/−12
- Clckwrks/Admin/EditFeedConfig.hs +0/−41
- Clckwrks/Admin/EditPage.hs +0/−90
- Clckwrks/Admin/EditSettings.hs +13/−5
- Clckwrks/Admin/NewPage.hs +0/−33
- Clckwrks/Admin/Pages.hs +0/−29
- Clckwrks/Admin/PreviewPage.hs +0/−37
- Clckwrks/Admin/Route.hs +7/−24
- Clckwrks/Admin/Template.hs +54/−70
- Clckwrks/Admin/URL.hs +3/−10
- Clckwrks/GetOpts.hs +48/−8
- Clckwrks/IOThread.hs +2/−2
- Clckwrks/Menu/API.hs +0/−48
- Clckwrks/Menu/Acid.hs +0/−45
- Clckwrks/Menu/Edit.hs +0/−330
- Clckwrks/Menu/Types.hs +0/−101
- Clckwrks/Monad.hs +164/−73
- Clckwrks/NavBar/API.hs +28/−0
- Clckwrks/NavBar/Acid.hs +29/−0
- Clckwrks/NavBar/EditNavBar.hs +247/−0
- Clckwrks/NavBar/Types.hs +33/−0
- Clckwrks/Page/API.hs +0/−129
- Clckwrks/Page/Acid.hs +0/−207
- Clckwrks/Page/Atom.hs +0/−90
- Clckwrks/Page/PreProcess.hs +0/−70
- Clckwrks/Page/Types.hs +0/−199
- Clckwrks/Plugin.hs +28/−95
- Clckwrks/ProfileData/Acid.hs +11/−0
- Clckwrks/ProfileData/EditProfileData.hs +12/−5
- Clckwrks/Route.hs +85/−0
- Clckwrks/Server.hs +48/−50
- Clckwrks/Types.hs +32/−6
- Clckwrks/URL.hs +10/−8
- clckwrks.cabal +9/−17
Clckwrks.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} module Clckwrks ( module Clckwrks.Acid- , module Clckwrks.Menu.API+-- , 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@@ -24,10 +22,8 @@ import Clckwrks.Acid import Clckwrks.Admin.URL-import Clckwrks.Menu.API+-- 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
Clckwrks/Acid.hs view
@@ -1,16 +1,22 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} module Clckwrks.Acid where -import Clckwrks.Menu.Acid (MenuState , initialMenuState)-import Clckwrks.Page.Acid (PageState , initialPageState)+import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState) import Clckwrks.ProfileData.Acid (ProfileDataState, initialProfileDataState)+import Clckwrks.Types (UUID) import Clckwrks.URL (ClckURL)+import Control.Applicative ((<$>)) import Control.Exception (bracket, catch, throw) import Control.Concurrent (killThread, forkIO)-import Data.Acid (AcidState)+import Control.Monad.Reader (ask)+import Control.Monad.State (modify)+import Data.Acid (AcidState, Query, Update, makeAcidic) import Data.Acid.Local (openLocalStateFrom, createArchive, createCheckpointAndClose) import Data.Acid.Remote (acidServer)+import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Text (Text) import Happstack.Auth.Core.Auth (AuthState , initialAuthState) import Happstack.Auth.Core.Profile (ProfileState , initialProfileState) import Network (PortID(UnixSocket))@@ -18,13 +24,53 @@ import System.Directory (removeFile) import System.FilePath ((</>)) import System.IO.Error (isDoesNotExistError)+import HSP.Google.Analytics (UACCT) +-- | 'CoreState' holds some values that are required by the core+-- itself, or which are useful enough to be shared with numerous+-- plugins/themes.+data CoreState = CoreState+ { coreUACCT :: Maybe UACCT -- ^ Google Account UAACT+ , coreRootRedirect :: Maybe Text+ }+ deriving (Eq, Data, Typeable, Show)+$(deriveSafeCopy 0 'base ''CoreState)++initialCoreState :: CoreState+initialCoreState = CoreState+ { coreUACCT = Nothing+ , coreRootRedirect = Nothing+ }++-- | get the 'UACCT' for Google Analytics+getUACCT :: Query CoreState (Maybe UACCT)+getUACCT = coreUACCT <$> ask++-- | set the 'UACCT' for Google Analytics+setUACCT :: Maybe UACCT -> Update CoreState ()+setUACCT mua = modify $ \cs -> cs { coreUACCT = mua }++-- | get the path that @/@ should redirect to+getRootRedirect :: Query CoreState (Maybe Text)+getRootRedirect = coreRootRedirect <$> ask++-- | set the path that @/@ should redirect to+setRootRedirect :: Maybe Text -> Update CoreState ()+setRootRedirect path = modify $ \cs -> cs { coreRootRedirect = path }++$(makeAcidic ''CoreState+ [ 'getUACCT+ , 'setUACCT+ , 'getRootRedirect+ , 'setRootRedirect+ ])+ data Acid = Acid { acidAuth :: AcidState AuthState , acidProfile :: AcidState ProfileState , acidProfileData :: AcidState ProfileDataState- , acidPage :: AcidState PageState- , acidMenu :: AcidState (MenuState ClckURL)+ , acidCore :: AcidState CoreState+ , acidNavBar :: AcidState NavBarState } class GetAcidState m st where@@ -33,15 +79,14 @@ 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))+ bracket (openLocalStateFrom (basePath </> "core") initialCoreState) (createArchiveCheckpointAndClose) $ \core ->+ bracket (openLocalStateFrom (basePath </> "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar ->+ 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 core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e) createArchiveCheckpointAndClose acid =
− Clckwrks/Admin/EditFeedConfig.hs
@@ -1,41 +0,0 @@-{-# 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
@@ -1,90 +0,0 @@-{-# 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
@@ -3,8 +3,9 @@ module Clckwrks.Admin.EditSettings where import Clckwrks+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..)) import Clckwrks.Admin.Template (template)-import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..))+-- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..)) import HSP.Google.Analytics (UACCT(..)) import Text.Reform import Text.Reform.Happstack@@ -26,14 +27,21 @@ editSettingsForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT) editSettingsForm muacct =- fieldset $- ol $- ((li $ label "Google Analytics UACCT:") ++> (li $ (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*- inputSubmit "update"+ divHorizontal $+ fieldset $+ (divControlGroup $+ (label "Google Analytics UACCT" `setAttrs` [("class":="control-label")]) ++>+ (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn")]) where+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>]) 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
@@ -1,33 +0,0 @@-{-# 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
@@ -1,29 +0,0 @@-{-# 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
@@ -1,37 +0,0 @@-{-# 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 Control.Monad.State (get)-import qualified Data.Set as Set-import Web.Plugins.Core (getTheme)--previewPage :: PageId -> Clck ClckURL Response-previewPage 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- cs <- get- ttl <- getPageTitle- bdy <- getPageContent- mTheme <- getTheme (plugins cs)- case mTheme of- Nothing -> escape $ internalServerError $ toResponse "No theme package is loaded."- (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme ttl () bdy)- else unauthorized (toResponse $ "Sorry, you need Administrator access to view this page.")
Clckwrks/Admin/Route.hs view
@@ -1,32 +1,15 @@ 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+import Clckwrks (AdminURL(..), Clck, ClckURL(..), Response, nestURL)+import Clckwrks.Admin.Console (consolePage)+import Clckwrks.Admin.EditSettings (editSettings)+import Clckwrks.NavBar.EditNavBar (editNavBar, navBarPost) -- | 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 pid -- FIXME- NewPost -> nestURL Admin $ newPage Post- Pages -> nestURL Admin $ pages- EditMenu ->- do menu <- query AskMenu- editMenu (menu :: Menu ClckURL)- MenuPOST -> menuPost-+ EditSettings -> editSettings (Admin url)+ EditNavBar -> editNavBar+ NavBarPost -> navBarPost
Clckwrks/Admin/Template.hs view
@@ -2,22 +2,16 @@ {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Clckwrks.Admin.Template where -import Clckwrks hiding (mapM, sequence)-import Control.Arrow (second)+import Clckwrks 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.Maybe (mapMaybe)+import qualified Data.Text as T+import Data.Set (Set)+import qualified Data.Set as Set -import Data.Monoid-import Data.Foldable-import Data.Traversable template ::- ( Functor m- , Monad m+ ( Happstack m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response@@ -25,77 +19,67 @@ toResponse <$> (unXMLGenT $ <html> <head>+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" /> <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>+ <script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/js/bootstrap.min.js" ></script>+ <title><% title %></title> <% headers %> </head> <body>- <% sidebar %>- <div id="admin-body">- <% body %>+ <div class="navbar">+ <div class="navbar-inner">+ <div class="container-fluid">+ <a href="/" class="brand">Back to Your Site</a>+ </div>+ </div> </div>++ <div class="container-fluid">+ <div class="row-fluid">+ <div class="span2">+ <% sidebar %>+ </div>+ <div class="span10">+ <% body %>+ </div>+ </div>+ </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>+sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML+sidebar = adminMenuXML -adminMenuXML :: (Functor m, Monad m) => XMLGenT (ClckT url m) XML+adminMenuXML :: (Happstack m) => XMLGenT (ClckT url m) XML adminMenuXML =- do menu <- adminMenus <$> get- <ul id="admin-menu">- <% mapM mkMenu menu %>+ do allMenus <- adminMenus <$> get+ usersMenus <- filterByRole allMenus+ <div class="well">+ <ul class="nav nav-list">+ <% mapM mkMenu usersMenus %> </ul>+ </div> where- mkMenu :: (Functor m, Monad m) => (T.Text, [(T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML+-- filterByRole :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])]+ filterByRole menus =+ do userRoles <- lift getUserRoles+ return $ mapMaybe (sectionFilter userRoles) menus+ sectionFilter userRoles (title, items) =+ case filter (itemFilter userRoles) items of+ [] -> Nothing+ items' -> Just (title, items')+ itemFilter userRoles (visibleRoles, _, _) = not (Set.null (Set.intersection userRoles visibleRoles))++-- mkMenu :: (Functor m, Monad m) => (T.Text, [(Set Role, 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>+ <%>+ <li class="nav-header"><% category %></li>+ <% mapM mkLink links %>+ </%>+ mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML+ mkLink (_visible, title, url) =+ <li><a href=url><% title %></a></li>
Clckwrks/Admin/URL.hs view
@@ -1,23 +1,16 @@ {-# 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+ | EditNavBar+ | NavBarPost deriving (Eq, Ord, Read, Show, Data, Typeable) $(derivePathInfo ''AdminURL)-$(deriveSafeCopy 1 'base ''AdminURL)+$(deriveSafeCopy 2 'base ''AdminURL)
Clckwrks/GetOpts.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE RecordWildCards #-} module Clckwrks.GetOpts where -import Clckwrks.Monad-import System.Console.GetOpt -- (Permute, OptDescr, getOpt)-import System.Environment-import System.Exit-+import Control.Applicative ((<$>))+import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..))+import Data.Maybe (fromMaybe)+import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)+import System.Directory (doesFileExist)+import System.Exit (exitFailure, exitSuccess) ------------------------------------------------------------------------------ -- Command line options@@ -26,6 +28,9 @@ 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 [] ["https-port"] (ReqArg setTLSPort "port") ("Port to bind https server, default:" ++ maybe "disabled." show (clckTLSPort <$> (clckTLS def)))+ , Option [] ["tls-cert"] (ReqArg setTLSCert "path") ("Path to tls .cert file. (required for https).")+ , Option [] ["tls-key"] (ReqArg setTLSKey "path") ("Path to tls .key file. (required for https).") , 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))@@ -36,8 +41,19 @@ , Option [] ["enable-analytics"] (NoArg setAnalytics) "enable google analytics tracking" ] where+ nullTLSSettings = TLSSettings { clckTLSPort = 443+ , clckTLSCert = ""+ , clckTLSKey = ""+ }+ modifyTLS f cc =+ Just $ case clckTLS cc of+ Nothing -> f nullTLSSettings+ (Just tls) -> f tls noop _ = ModifyConfig $ id setPort str = ModifyConfig $ \c -> c { clckPort = read str }+ setTLSPort str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSPort = read str }) c }+ setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = str }) c }+ setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = str }) c } setHostname str = ModifyConfig $ \c -> c { clckHostname = str } setHidePort = ModifyConfig $ \c -> c { clckHidePort = True } setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str }@@ -49,20 +65,44 @@ -- | 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 :: [OptDescr Flag] -> [String] -> IO (ClckwrksConfig -> IO 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+ else do let f config = checkTLS $ foldr (.) id [f | (ModifyConfig f) <- flags ] config return f (_,_,errs) -> do putStr ("Failure while parsing command line:\n"++unlines errs) putStr (helpMessage opts) exitFailure-+ where+ checkTLS cc =+ case clckTLS cc of+ Nothing -> return cc+ (Just TLSSettings{..}) ->+ do mCertError <-+ if null clckTLSCert+ then return (Just "--tls-cert not set.")+ else do b <- doesFileExist clckTLSCert+ if b+ then return Nothing+ else return (Just $ "Can not find the file " ++ clckTLSCert)+ mKeyError <-+ if null clckTLSKey+ then return (Just "--tls-key not set.")+ else do b <- doesFileExist clckTLSKey+ if b+ then return Nothing+ else return (Just $ "Can not find the file " ++ clckTLSKey)+ case (mCertError, mKeyError) of+ (Nothing, Nothing) -> return cc+ _ -> do putStrLn "It seems you are trying to enable https support. To do that you need to use both the --tls-cert and --tls-key flags."+ putStrLn $ unlines [fromMaybe "" mCertError, fromMaybe "" mKeyError]+ putStrLn $ helpMessage opts+ exitFailure -- | A simple usage message listing all flags possible. helpMessage :: [OptDescr Flag] -> String
Clckwrks/IOThread.hs view
@@ -29,7 +29,7 @@ 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)@@ -40,7 +40,7 @@ -> a -- ^ argument to the function in the IOThread -> IO b -- ^ value returned by the function in the IOThread ioRequest iot a =- do resp <- newEmptyMVar + do resp <- newEmptyMVar writeChan (ioThreadChan iot) (a, resp) e <- readMVar resp case e of
− Clckwrks/Menu/API.hs
@@ -1,48 +0,0 @@-{-# 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
@@ -1,45 +0,0 @@-{-# 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
@@ -1,330 +0,0 @@-{-# 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
@@ -1,101 +0,0 @@-{-# 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
@@ -2,16 +2,21 @@ module Clckwrks.Monad ( Clck , ClckPlugins+ , ClckPluginsSt+ , initialClckPluginsSt , ClckT(..) , ClckForm , ClckFormT , ClckFormError(..) , ChildType(..) , ClckwrksConfig(..)+ , TLSSettings(..) , AttributeType(..) , Theme(..) , ThemeName+ , themeTemplate , calcBaseURI+ , calcTLSBaseURI , evalClckT , execClckT , runClckT@@ -20,33 +25,38 @@ , ClckState(..) , getUserId , Content(..)- , markupToContent+-- , markupToContent -- , addPreProcessor , addAdminMenu+ , getNavBarLinks , addPreProc- , setCurrentPage+ , addNavBarCallback+ , getPreProcessors -- , getPrefix , getEnableAnalytics+ , googleAnalytics , getUnique , setUnique , requiresRole , requiresRole_+ , getUserRoles , query , update , nestURL+ , withAbs+ , withAbs' , 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.Acid (Acid(..), CoreState, GetAcidState(..), GetUACCT(..))+import Clckwrks.ProfileData.Acid (ProfileDataState, ProfileDataError(..), GetRoles(..), HasRole(..)) import Clckwrks.ProfileData.Types (Role(..))-import Clckwrks.Types (Prefix, Trust(Trusted))+import Clckwrks.NavBar.Acid (NavBarState)+import Clckwrks.NavBar.Types (NavBarLinks(..))+import Clckwrks.Types (NamedLink(..), Prefix, Trust(Trusted)) import Clckwrks.Unauthorized (unauthorizedPage) import Clckwrks.URL (ClckURL(..)) import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many)@@ -61,15 +71,18 @@ 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 Data.Monoid ((<>), mappend, mconcat) import qualified Data.Text as Text+import Data.Traversable (sequenceA) 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.Maybe (fromJust) import Data.SafeCopy (SafeCopy(..)) import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder, fromText)@@ -79,11 +92,11 @@ 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 (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Input, Request(..), Response, HasRqData(..), ServerPartT, UnWebT, internalServerError, mapServerPartT, escape, toResponse) 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.Google.Analytics (UACCT, analyticsAsync) import HSP.ServerPartT () import HSX.XMLGenerator (XMLGen(..)) import HSX.JMacro (IntegerSupply(..))@@ -94,13 +107,27 @@ 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 Web.Plugins.Core (Plugins, getConfig, getPluginsSt, modifyPluginsSt, getTheme) 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])+data ClckPluginsSt = ClckPluginsSt+ { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text]+ , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]+ } +initialClckPluginsSt :: ClckPluginsSt+initialClckPluginsSt = ClckPluginsSt+ { cpsPreProcessors = []+ , cpsNavBarLinks = []+ }++-- | ClckPlugins+--+-- newtype Plugins theme m hook config st+type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+ type ThemeName = T.Text data Theme = Theme@@ -111,34 +138,65 @@ -> headers -> body -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML- , themeBlog :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML+-- , themeBlog :: XMLGenT (ClckT ClckURL (ServerPartT IO)) XML , themeDataDir :: IO FilePath } ++themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers+ , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body+ ) =>+ ClckPlugins+ -> T.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." :: T.Text)+ (Just theme) -> fmap toResponse $ unXMLGenT $ (_themeTemplate theme ttl hdrs bdy)++++data TLSSettings = TLSSettings+ { clckTLSPort :: Int+ , clckTLSCert :: FilePath+ , clckTLSKey :: 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+ { clckHostname :: String -- ^ external name of the host+ , clckPort :: Int -- ^ port to listen on+ , clckTLS :: Maybe TLSSettings -- ^ HTTPS+ , 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 ""+calcBaseURI c =+ Text.pack $ "http://" ++ (clckHostname c) ++ if ((clckPort c /= 80) && (clckHidePort c == False)) then (':' : show (clckPort c)) else "" +calcTLSBaseURI :: ClckwrksConfig -> Maybe T.Text+calcTLSBaseURI c =+ case clckTLS c of+ Nothing -> Nothing+ (Just tlsSettings) ->+ Just $ Text.pack $ "https://" ++ (clckHostname c) ++ if ((clckPort c /= 443) && (clckHidePort c == False)) then (':' : show (clckTLSPort tlsSettings)) else ""+ data ClckState = ClckState { acidState :: Acid- , currentPage :: PageId , uniqueId :: TVar Integer -- only unique for this request- , adminMenus :: [(T.Text, [(T.Text, T.Text)])]+ , adminMenus :: [(T.Text, [(Set Role, 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])+ , plugins :: ClckPlugins } newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a }@@ -201,14 +259,6 @@ 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 :: (MonadIO m) => PageId -> ClckT url m ()-setCurrentPage pid =- modify $ \s -> s { currentPage = pid }---- getPrefix :: Clck url Prefix--- getPrefix = componentPrefix <$> get- setUnique :: (Functor m, MonadIO m) => Integer -> ClckT url m () setUnique i = do u <- uniqueId <$> get@@ -228,7 +278,7 @@ getEnableAnalytics :: (Functor m, MonadState ClckState m) => m Bool getEnableAnalytics = enableAnalytics <$> get -addAdminMenu :: (Monad m) => (T.Text, [(T.Text, T.Text)]) -> ClckT url m ()+addAdminMenu :: (Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> ClckT url m () addAdminMenu (category, entries) = modify $ \cs -> let oldMenus = adminMenus cs@@ -252,6 +302,21 @@ nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a nestURL f (ClckT r) = ClckT $ R.nestURL f r +withAbs :: (Happstack m) => ClckT url m a -> ClckT url m a+withAbs m =+ do secure <- rqSecure <$> askRq+ clckState <- get+ cc <- getConfig (plugins clckState)+ let base = if secure then (fromJust $ calcTLSBaseURI cc) else calcBaseURI cc+ withAbs' base m++withAbs' :: T.Text+ -> ClckT url m a+ -> ClckT url m a+withAbs' prefix (ClckT (RouteT r)) =+ ClckT $ RouteT $ \showFn ->+ r (\url params -> prefix <> showFn url params)+ instance (Monad m) => MonadRoute (ClckT url m) where type URL (ClckT url m) = url askRouteFn = ClckT $ askRouteFn@@ -277,11 +342,11 @@ 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) CoreState where+ getAcidState = (acidCore . 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) NavBarState where+ getAcidState = (acidNavBar . acidState) <$> get instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileDataState where getAcidState = (acidProfileData . acidState) <$> get@@ -359,14 +424,6 @@ 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) @@ -407,20 +464,12 @@ 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) @@ -465,27 +514,12 @@ 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]+ Plugins theme n hook config ClckPluginsSt -> (TL.Text -> ClckT ClckURL IO TL.Text) -> m () addPreProc plugins p =- modifyPluginsSt plugins $ \ps -> p : ps+ modifyPluginsSt plugins $ \cps -> cps { cpsPreProcessors = p : (cpsPreProcessors cps) } -- * Preprocess @@ -552,3 +586,60 @@ if r then return url else escape $ unauthorizedPage ("You do not have permission to view this page." :: T.Text)++getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role)+getUserRoles =+ do mu <- getUserId+ case mu of+ Nothing -> return (Set.singleton Visitor)+ (Just u) ->+ do mr <- query (GetRoles u)+ case mr of+ Nothing -> return Set.empty+ (Just r) -> return r++------------------------------------------------------------------------------+-- NavBar callback+------------------------------------------------------------------------------++addNavBarCallback :: (MonadIO m) =>+ Plugins theme n hook config ClckPluginsSt+ -> ClckT ClckURL IO (String, [NamedLink])+ -> m ()+addNavBarCallback plugins ml =+ modifyPluginsSt plugins $ \cps -> cps { cpsNavBarLinks = (cpsNavBarLinks cps) ++ [ml] }++getNavBarLinks :: (MonadIO m) =>+ Plugins theme n hook config ClckPluginsSt+ -> ClckT ClckURL m NavBarLinks+getNavBarLinks plugins =+ mapClckT liftIO $+ do genNavBarLinks <- (cpsNavBarLinks <$> getPluginsSt plugins)+ NavBarLinks <$> sequenceA genNavBarLinks++getPreProcessors :: (MonadIO m) =>+ Plugins theme n hook config ClckPluginsSt+ -> ClckT url m [TL.Text -> ClckT ClckURL IO TL.Text]+getPreProcessors plugins =+ mapClckT liftIO $+ (cpsPreProcessors <$> getPluginsSt plugins)+++-- | 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
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.NavBar.API where++import Clckwrks+import Clckwrks.NavBar.Acid+import Clckwrks.NavBar.Types++getNavBarData :: (Functor m, MonadIO m) => ClckT url m NavBar+getNavBarData = query GetNavBar++getNavBar :: GenXML (Clck ClckURL)+getNavBar =+ do navBar <- query GetNavBar+ navBarHTML navBar++navBarHTML :: NavBar -> GenXML (Clck ClckURL)+navBarHTML (NavBar navBarItems) =+ <div class="navbar">+ <div class="navbar-inner">+ <ul class="nav">+ <% mapM mkNavBarItem navBarItems %>+ </ul>+ </div>+ </div>++mkNavBarItem :: NavBarItem -> GenXML (Clck ClckURL)+mkNavBarItem (NBLink (NamedLink ttl lnk)) =+ <li><a href=lnk><% ttl %></a></li>
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+module Clckwrks.NavBar.Acid where++import Clckwrks.NavBar.Types (NavBar(..), NavBarItem(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (modify)+import Data.Acid (Update, Query, makeAcidic)+import Data.Data (Data, Typeable)+import Data.SafeCopy (base, deriveSafeCopy)++data NavBarState = NavBarState+ { navBar :: NavBar+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'base ''NavBarState)++initialNavBarState :: NavBarState+initialNavBarState =+ NavBarState { navBar = NavBar [] }++setNavBar :: NavBar+ -> Update NavBarState ()+setNavBar m = modify $ \ms -> ms { navBar = m }++getNavBar :: Query NavBarState NavBar+getNavBar = navBar <$> ask++$(makeAcidic ''NavBarState ['getNavBar, 'setNavBar])
@@ -0,0 +1,247 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, QuasiQuotes, RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Clckwrks.NavBar.EditNavBar where++import Clckwrks.Admin.Template (template)+import Control.Applicative ((<$>))+import Clckwrks (query, update)+import Clckwrks.NavBar.Acid (GetNavBar(..), SetNavBar(..))+import Clckwrks.NavBar.Types (NavBar(..), NavBarLinks(..), NavBarItem(..))+import Clckwrks.Monad (Clck(..), ClckState(..), getNavBarLinks, mapClckT)+import Clckwrks.Types (NamedLink(..))+import Clckwrks.URL (ClckURL(..), AdminURL(..))+import Control.Monad.State (get)+import Control.Monad.Trans (lift, liftIO)+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object)+import Data.Text (Text)+import Data.Tree (Tree(..))+import qualified Data.Vector as Vector+import Happstack.Server (Response, internalServerError, lookBS, ok, toResponse)+import HSP+import Language.Javascript.JMacro+import Web.Routes (showURL)++editNavBar :: Clck ClckURL Response+editNavBar =+ do p <- plugins <$> get+ links <- getNavBarLinks p+-- liftIO $ print (toJSON links)+ currentNavBar <- query GetNavBar+ template "Edit NavBar" (headers currentNavBar links) $+ <%>+ <h1>NavBar Editor</h1>+ <div id="alert">+ </div>+ <div class="form-horizontal">+ <fieldset>+ <legend>Add Link</legend>+ <div class="control-group">+ <label class="control-label" for="plugin-list">Select a plugin...</label>+ <div class="controls">+ <select id="plugin-list"></select><br />+ </div>+ </div>+ <div class="control-group">+ <label class="control-label" for="navBar-item-list">then select a link</label>+ <div class="controls">+ <div class="input-append">+ <select id="navBar-item-list"></select>+ <button class="btn" id="add-link">Add Link</button>+ </div>+ </div>+ </div>+ </fieldset>+ -- <button id="add-sub-navBar">Add Sub-NavBar</button><br />+ <fieldset>+ <legend>Other Actions</legend>+ <div class="control-group">+ <label class="control-label" for="remove-item"></label>+ <div class="controls">+ <button class="btn btn-danger" id="remove-item"><i class="icon-remove icon-white"></i> Remove Selected Item</button>+ </div>+ </div>+ <div class="control-group">+ <label class="control-label" for="saveChanges"></label>+ <div class="controls">+ <button class="btn btn-success" id="saveChanges"><i class="icon-ok icon-white"></i> Save Changes</button>+ </div>+ </div>+ </fieldset>++ <fieldset>+ <legend>NavBar</legend>+ <p><i>Drag and Drop to rearrange. Click to rename.</i></p>+ <div id="navBar"></div>+ </fieldset>+ </div>+ </%>+ where+ headers currentNavBar navBarLinks+ = do navBarUpdate <- showURL (Admin NavBarPost)+ <%>+ <script type="text/javascript" src="/jstree/jquery.jstree.js" ></script>+ <% [$jmacro|+ function !doubleClickCB(e, dt) {+ alert(dt.rslt.o);+// navBar.rename(d.rslt);+ };++ $(document).ready(function ()+ { $("#navBar").jstree(`(jstree currentNavBar)`);+ var !navBar = $.jstree._reference("#navBar");+ $("#navBar").bind("select_node.jstree", function(e, d) { $("#navBar").jstree("rename", d.inst.o); } );++ // click elsewhere in document to unselect nodes+ $(document).bind("click", function (e) {+ if(!$(e.target).parents(".jstree:eq(0)").length) {+ $.jstree._focused().deselect_all();+ }+ });++ `(initializeDropDowns navBarLinks)`;+ `(removeItem)`;+ `(saveChanges navBarUpdate)`;+ });++ |]+ %>+ </%>++initializeDropDowns :: NavBarLinks -> JStat+initializeDropDowns navBarLinks' =+ [jmacro|+ var !navBarLinks = `(toJSON navBarLinks')`;+ var pluginList = $('#plugin-list');+ var navBarItemList = $('#navBar-item-list');++ function populateLinks (pluginIndex) {+ navBarItemList.empty();+ for (var i = 0; i < navBarLinks[pluginIndex].pluginLinks.length; i++) {+ var option = $('<option></option>', { value : [pluginIndex,i] }).text(navBarLinks[pluginIndex].pluginLinks[i].navBarItemName);+ option.data("navBarItem", navBarLinks[pluginIndex].pluginLinks[i].navBarItemName);+ navBarItemList.append(option);+ }+ }++ for (var p = 0; p < navBarLinks.length; p++) {+ var option = $('<option></option>', { 'value' : p }).text(navBarLinks[p].pluginName);+ option.text(navBarLinks[p].pluginName);+ pluginList.append(option);+ }+ populateLinks(0);+ pluginList.change(function() { populateLinks($(this).val()); });++ // add handler to add-link button+ $("#add-link").click(function () {+ var indexes = navBarItemList.val().split(',');+ var navBarItem = navBarLinks[indexes[0]].pluginLinks[indexes[1]];+ var entry = { 'state' : 'open'+ , 'data' : { 'title' : navBarItem.navBarItemName }+ , 'attr' : { 'rel' : 'target' }+ , 'metadata'+ : { 'link' : { 'navBarName' : navBarItem.navBarItemName+ , 'navBarLink' : navBarItem.navBarItemLink+ }+ }+ };+ navBar.create(null, "last", entry , null, true);+ });++ |]++saveChanges :: Text -> JStat+saveChanges navBarUpdateURL =+ [$jmacro|+ $("#saveChanges").click(function () {+ var tree = $("#navBar").jstree("get_json", -1);+ var json = JSON.stringify(tree);+ console.log(json);+ $.post(`(navBarUpdateURL)`, { tree : json });+ var alert = $('<div class="alert alert-success"><button type="button" class="close" data-dismiss="alert">×</button><span>Changes Saved!</span></div>');+// alert.alert();+ $("#alert").append(alert);+ });+ |]+++removeItem :: JStat+removeItem =+ [$jmacro|+ $("#remove-item").click(function() {+ navBar.remove(navBar.get_selected());+ });+ |]++jstree :: NavBar -> Value+jstree navBar =+ object [ "types" .=+ object [ "types" .=+ object [ "root" .=+ object [ "max_children" .= (-1 :: Int)+ ]+ , "navBar" .=+ object [ "max_children" .= (-1 :: Int)+ ]+ , "target" .=+ object [ "max_children" .= (0 :: Int)+ , "icon" .= False+ ]+ ]+ ]+ , "dnd" .=+ object [ "drop_target" .= False+ , "drag_target" .= False+ ]+ , "ui" .=+ object [ "initially_select" .= ([ "tree-root" ] :: [String])+ ]+ , "json_data" .= navBarToJSTree navBar+ , "plugins" .= ([ "themes", "ui", "crrm", "types", "json_data", "dnd" ] :: [String])+ ]++navBarToJSTree :: NavBar -> Value+navBarToJSTree (NavBar items) =+ object [ "data" .= (toJSON $ map navBarItemToJSTree items)+ ]++navBarItemToJSTree :: NavBarItem -> Value+navBarItemToJSTree (NBLink NamedLink{..}) =+ object [ "data" .=+ object [ "title" .= namedLinkTitle+ ]+ , "attr" .=+ object [ "rel" .= ("target" :: String)+ ]+ , "metadata" .=+ object [ "link" .=+ object [ "navBarLink" .= namedLinkURL+ ]+ ]+ ]++navBarPost :: Clck ClckURL Response+navBarPost =+ do t <- lookBS "tree"+ let mu = decode t :: Maybe NavBarUpdate+-- liftIO $ print t+-- liftIO $ print mu+ case mu of+ Nothing ->+ do internalServerError $ toResponse ("navBarPost: failed to decode JSON data" :: Text)+ (Just (NavBarUpdate u)) ->+ do update (SetNavBar u)+ ok $ toResponse ()++newtype NavBarUpdate = NavBarUpdate NavBar deriving (Show)++instance FromJSON NavBarUpdate where+ parseJSON (Array a) = (NavBarUpdate . NavBar) <$> mapM parseJSON (Vector.toList a)++instance FromJSON NavBarItem where+ parseJSON (Object o) =+ do ttl <- o .: "data"+ meta <- o .: "metadata"+ link <- meta .: "link"+ navBarLink <- link .: "navBarLink"+ let nl = NamedLink ttl navBarLink+ return (NBLink nl)
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards, TemplateHaskell #-}+module Clckwrks.NavBar.Types where++import Clckwrks.Types (NamedLink(..))+import Data.Aeson (ToJSON(..), (.=), object)+import Data.Data (Data, Typeable)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Text (Text)++newtype NavBar = NavBar+ { navBarItems :: [NavBarItem]+ }+ deriving (Eq, Read, Show, Data, Typeable)++++data NavBarItem+ = NBLink NamedLink+ | NBSubNavBar Text NavBar+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''NavBar)+$(deriveSafeCopy 1 'base ''NavBarItem)++newtype NavBarLinks = NavBarLinks [(String, [NamedLink])]+ deriving (Eq, Read, Show, Data, Typeable)++instance ToJSON NavBarLinks where+ toJSON (NavBarLinks navBarLinks) =+ toJSON $ map (\(plugName, links) ->+ object [ "pluginName" .= plugName+ , "pluginLinks" .= map toJSON links+ ]) navBarLinks+
− Clckwrks/Page/API.hs
@@ -1,129 +0,0 @@-{-# 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
@@ -1,207 +0,0 @@-{-# 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
@@ -1,90 +0,0 @@-{-# 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
@@ -1,70 +0,0 @@-{-# 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
@@ -1,199 +0,0 @@-{-# 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
@@ -2,36 +2,13 @@ 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 Clckwrks.Types (NamedLink(..))+import Clckwrks.Route (routeClck)+import Control.Monad.State (get) import Data.Text (Text)+import qualified Data.Set as Set 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)+import Web.Plugins.Core (Plugin(..), addHandler, getPluginRouteFn, initPlugin) clckHandler :: (ClckURL -> [(Text, Maybe Text)] -> Text) -> ClckPlugins@@ -39,89 +16,45 @@ -> ClckT ClckURL (ServerPartT IO) Response clckHandler showRouteFn _plugins paths = case parseSegments fromPathSegments paths of- (Left e) -> notFound $ toResponse (show e)+ (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+clckMenuCallback :: ClckT ClckURL IO (String, [NamedLink])+clckMenuCallback =+ do adminURL <- showURL (Admin Console)+ return ("Clck", [NamedLink "Admin" adminURL]) clckInit :: ClckPlugins -> IO (Maybe Text) clckInit plugins = do (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)- addPreProc plugins (pageCmd clckShowFn)+ addNavBarCallback plugins clckMenuCallback addHandler plugins (pluginName clckPlugin) (clckHandler clckShowFn) return Nothing +addClckAdminMenu :: ClckT url IO ()+addClckAdminMenu =+ do p <- plugins <$> get+ (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin)+ addAdminMenu ( "Profile"+ , [ (Set.fromList [Administrator, Visitor], "Edit Your Profile" , clckShowURL (Profile EditProfileData) [])+ ]+ ) -clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ([TL.Text -> ClckT ClckURL IO TL.Text])+ addAdminMenu ( "Clckwrks"+ , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) [])+ , (Set.singleton Administrator, "Edit Settings", clckShowURL (Admin EditSettings) [])+ , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) [])+ ]+ )++clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt clckPlugin = Plugin { pluginName = "clck" , pluginInit = clckInit , pluginDepends = [] , pluginToPathInfo = toPathInfo- , pluginPostHook = return ()+ , pluginPostHook = addClckAdminMenu } plugin :: ClckPlugins
Clckwrks/ProfileData/Acid.hs view
@@ -10,6 +10,7 @@ , GetUsername(..) , GetUserIdUsernames(..) , HasRole(..)+ , GetRoles(..) , AddRole(..) , RemoveRole(..) , UsernameForId(..)@@ -115,6 +116,15 @@ do pds <- profileData <$> ask return $ map (\pd -> (dataFor pd, username pd)) (toList pds) +getRoles :: UserId+ -> Query ProfileDataState (Maybe (Set Role))+getRoles uid =+ do mp <- getProfileData uid+ case mp of+ Nothing -> return Nothing+ (Just profile) ->+ return (Just $ roles profile)+ hasRole :: UserId -> Set Role -> Query ProfileDataState Bool@@ -161,6 +171,7 @@ , 'newProfileData , 'getUsername , 'getUserIdUsernames+ , 'getRoles , 'hasRole , 'addRole , 'removeRole
Clckwrks/ProfileData/EditProfileData.hs view
@@ -9,8 +9,8 @@ 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, errorList)+import Text.Reform ((++>), mapView, transformEitherM)+import Text.Reform.HSP.Text (form, inputText, inputSubmit, label, fieldset, ol, li, errorList, setAttrs) import Text.Reform.Happstack (reform) -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not.@@ -38,11 +38,18 @@ profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL () profileDataFormlet pd@ProfileData{..} =- errorList ++> ((,) <$> (li $ label "username:" ) ++> (li $ inputText username)- <*> (li $ label" email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))- <* inputSubmit (pack "update"))+ divHorizontal $+ errorList ++>+ ((,) <$> (divControlGroup (label' "Username" ++> (divControls (inputText username))))+ <*> (divControlGroup (label'" Email (optional)" ++> (divControls (inputText (fromMaybe Text.empty email)))))+ <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` ("class" := "btn"))))) `transformEitherM` updateProfileData where+ label' str = (label str `setAttrs` [("class":="control-label")])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ updateProfileData :: (Text, Text) -> Clck ProfileDataURL (Either ClckFormError ()) updateProfileData (usrnm, eml) = do let newPd = pd { username = usrnm
+ Clckwrks/Route.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts, RecordWildCards, OverloadedStrings #-}+module Clckwrks.Route where++import Clckwrks+import Clckwrks.Admin.Route (routeAdmin)+import Clckwrks.BasicTemplate (basicTemplate)+import Clckwrks.Monad (calcTLSBaseURI, withAbs)+import Clckwrks.ProfileData.Route (routeProfileData)+import Control.Monad.State (MonadState(get))+import Data.Maybe (fromJust)+import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.Text (Text, pack)+import qualified Data.Text as Text+import Happstack.Auth (handleAuthProfile)+import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)+import Network.URI (unEscapeString)+import Paths_clckwrks (getDataDir)+import System.FilePath ((</>), makeRelative, splitDirectories)+import Web.Plugins.Core (Plugin(..), addHandler, getConfig, getTheme, getPluginRouteFn, initPlugin)++checkAuth :: (Happstack m, Monad m) =>+ ClckURL+ -> ClckT ClckURL m ClckURL+checkAuth url =+ case url of+ 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++routeClck :: ClckURL+ -> Clck ClckURL Response+routeClck url' =+ do url <- checkAuth url'+ setUnique 0+ case url of+ (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 clckState <- get+ cc <- getConfig (plugins clckState)+ let go = do let Acid{..} = acidState clckState+ u <- showURL $ Profile CreateNewProfileData+ showClckURL <- askRouteFn+ cs <- get+ let template' ttl hdr bdy = withRouteClckT (const showClckURL) $ themeTemplate (plugins cs) (pack ttl) hdr bdy+ withAbs $ nestURL Auth $ handleAuthProfile acidAuth acidProfile template' Nothing Nothing u apURL+ case clckTLS cc of+ Nothing -> go+ (Just tlsSettings) ->+ do secure <- rqSecure <$> askRq+ if secure+ then go+ else do u <- rqUri <$> askRq+ let sslU = ((Text.unpack $ fromJust $ calcTLSBaseURI cc) ++ u)+ seeOther sslU (toResponse ())++
Clckwrks/Server.hs view
@@ -2,43 +2,42 @@ 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 Clckwrks.Admin.Route (routeAdmin)+import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..), initialClckPluginsSt)+-- 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 (forkIO, killThread)+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 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+import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS)+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 ->+ withPlugins cc initialClckPluginsSt $ \plugins -> withAcid (fmap (\top -> top </> "_state") (clckTopDir cc)) $ \acid -> do u <- atomically $ newTVar 0 let clckState = ClckState { acidState = acid- , currentPage = PageId 0+-- , currentPage = PageId 0 , uniqueId = u , adminMenus = [] , enableAnalytics = clckEnableAnalytics cc@@ -54,10 +53,24 @@ 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'')+ clckState'' <- execClckT showFn clckState' $ sequence_ hooks+ httpTID <- forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'')++ mHttpsTID <-+ case clckTLS cc' of+ Nothing -> return Nothing+ (Just TLSSettings{..}) ->+ do let tlsConf = nullTLSConf { tlsPort = clckTLSPort+ , tlsCert = clckTLSCert+ , tlsKey = clckTLSKey+ }+ tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'')+ return (Just tid)+ -- putStrLn "Server Now Listening For Requests."+ waitForTermination+ killThread httpTID+ maybe (return ()) killThread mHttpsTID+ where handlers cc clckState = do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6))@@ -65,7 +78,7 @@ [ jsHandlers cc , dir "favicon.ico" $ notFound (toResponse ()) , dir "static" $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing []- , nullDir >> seeOther ("/clck/view-page/1" :: String) (toResponse ())+ , nullDir >> seeOther ("/page/view-page/1" :: String) (toResponse ()) -- FIXME: get redirect location from database , clckSite cc clckState ] @@ -76,21 +89,6 @@ , 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 =
Clckwrks/Types.hs view
@@ -1,17 +1,43 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}-module Clckwrks.Types where+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, TemplateHaskell, OverloadedStrings #-}+module Clckwrks.Types+ ( UUID+ , Prefix(..)+ , Trust(..)+ , NamedLink(..)+ ) where +import Data.Aeson (ToJSON(..), (.=), object) import Data.Data (Data, Typeable) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)-import Data.Text as T+import Data.Text (Text)+import Data.UUID (UUID)+import HSP.Google.Analytics (UACCT) ++-- | 'SafeCopy' instances for some 3rd party types+$(deriveSafeCopy 0 'base ''UACCT)+$(deriveSafeCopy 0 'base ''UUID)+ -- | at present this is only used by the menu editor-newtype Prefix = Prefix { prefixText :: T.Text }+newtype Prefix = Prefix { prefixText :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy) data Trust- = Trusted -- ^ used when the author can be trusted (sanitization is not performed)+ = 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)++data NamedLink = NamedLink+ { namedLinkTitle :: Text+ , namedLinkURL :: Text+ }+ deriving (Eq, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''NamedLink)++instance ToJSON NamedLink where+ toJSON (NamedLink{..}) =+ object [ "navBarItemName" .= namedLinkTitle+ , "navBarItemLink" .= namedLinkURL+ ]+
Clckwrks/URL.hs view
@@ -9,9 +9,9 @@ ) where import Clckwrks.Admin.URL (AdminURL(..))-import Clckwrks.Page.Acid (PageId(..))+-- import Clckwrks.Page.Acid (PageId(..))+-- import Clckwrks.Page.Types (Slug(..)) 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)@@ -19,7 +19,7 @@ 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@@ -31,20 +31,22 @@ | 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+-}+ = ThemeData FilePath | PluginData Text FilePath | Admin AdminURL | Profile ProfileDataURL | Auth AuthProfileURL deriving (Eq, Ord, Data, Typeable, Read, Show)-$(deriveSafeCopy 2 'extension ''ClckURL)-+(deriveSafeCopy 3 'base ''ClckURL)+{- instance Migrate ClckURL where type MigrateFrom ClckURL = ClckURL_1 migrate (ViewPage_1 pid) = ViewPage pid@@ -55,6 +57,7 @@ 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)@@ -63,6 +66,5 @@ $(deriveSafeCopy 1 'base ''OpenIdURL) $(deriveSafeCopy 1 'base ''AuthMode) $(deriveSafeCopy 1 'base ''OpenIdProvider)- $(derivePathInfo ''ClckURL)
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.14.2+Version: 0.16.2 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@@ -37,12 +37,7 @@ 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@@ -50,15 +45,10 @@ 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.NavBar.Acid+ Clckwrks.NavBar.API+ Clckwrks.NavBar.EditNavBar+ Clckwrks.NavBar.Types Clckwrks.Plugin Clckwrks.ProfileData.URL Clckwrks.ProfileData.Route@@ -67,6 +57,7 @@ Clckwrks.ProfileData.API Clckwrks.ProfileData.EditProfileData Clckwrks.ProfileData.EditProfileDataFor+ Clckwrks.Route Clckwrks.Types Clckwrks.Unauthorized Clckwrks.URL@@ -78,14 +69,15 @@ aeson >= 0.5 && < 0.7, attoparsec == 0.10.*, base < 5,- blaze-html == 0.5.*,+ blaze-html >= 0.5 && < 0.7, 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-authenticate == 0.10.*, happstack-hsp == 7.1.*, happstack-server >= 7.0 && < 7.2,+ happstack-server-tls >= 7.0 && < 7.2, hsp == 0.7.*, hsx == 0.10.*, hsx-jmacro == 7.2.*,