clckwrks-plugin-redirect (empty) → 0.0.1
raw patch · 10 files changed
+905/−0 lines, 10 filesdep +acid-statedep +aesondep +attoparsecsetup-changed
Dependencies added: acid-state, aeson, attoparsec, base, clckwrks, clckwrks-plugin-page, clckwrks-plugin-redirect, clckwrks-theme-bootstrap, containers, filepath, happstack-hsp, happstack-server, hsp, hsx2hs, ixset, mtl, old-locale, random, reform, reform-happstack, reform-hsp, safecopy, template-haskell, text, uuid, uuid-orphans, web-plugins, web-routes, web-routes-happstack, web-routes-th
Files
- Clckwrks/Redirect/Acid.hs +49/−0
- Clckwrks/Redirect/Monad.hs +134/−0
- Clckwrks/Redirect/Plugin.hs +162/−0
- Clckwrks/Redirect/Route.hs +87/−0
- Clckwrks/Redirect/Types.hs +245/−0
- Clckwrks/Redirect/URL.hs +20/−0
- LICENSE +30/−0
- Setup.hs +13/−0
- clckwrks-plugin-redirect.cabal +79/−0
- test/Test.hs +86/−0
+ Clckwrks/Redirect/Acid.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.Redirect.Acid+ ( -- * state+ RedirectState+ , initialRedirectState+ -- * events+ , GetRedirect(..)+-- , SetRedirect(..)+ ) where++import Clckwrks (UserId(..))+-- import Clckwrks.Redirect.Types ()+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.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+-- import Data.UUID (UUID)+-- import qualified Data.UUID as UUID+-- import HSP.Google.Analytics (UACCT)++data RedirectState = RedirectState+ { redirects :: Map [Text] Text+ }+ deriving (Eq, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''RedirectState++initialRedirectState :: IO RedirectState+initialRedirectState =+ pure $ RedirectState { redirects = Map.empty }++getRedirect :: [Text]+ -> Query RedirectState (Maybe Text)+getRedirect paths =+ do s <- ask+ pure $ Map.lookup paths (redirects s)++makeAcidic ''RedirectState+ [ 'getRedirect+ ]
+ Clckwrks/Redirect/Monad.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}+module Clckwrks.Redirect.Monad where++import Control.Applicative ((<$>))+import Control.Monad (foldM)+import Control.Monad.Fail (MonadFail(fail))+import Control.Monad.Reader (MonadReader(ask,local), ReaderT(runReaderT))+import Control.Monad.State (StateT, put, get, modify)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.Text.Lazy as LT+import Clckwrks.Acid (GetAcidState(..))+import Clckwrks.Monad (Content(..), ClckT(..), ClckFormT, ClckState(..), ClckPluginsSt(..), mapClckT, runClckT, withRouteClckT, getPreProcessors)+import Clckwrks.URL (ClckURL)+import Clckwrks.Redirect.Acid (RedirectState(..))+import Clckwrks.Redirect.Types ()+import Clckwrks.Redirect.URL (RedirectURL(..), RedirectAdminURL(..))+import Clckwrks.Redirect.Types ()+import Clckwrks.Plugin (clckPlugin)+import Control.Monad.Trans (lift)+import Data.Acid (AcidState)+import Data.Data (Typeable)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Happstack.Server (Happstack, Input, ServerPartT)+import HSP.XMLGenerator+import HSP.XML+import Text.Reform (CommonFormError, FormError(..))+import Web.Plugins.Core (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn)+import Web.Routes (RouteT(..), showURL, withRouteT)++data RedirectConfig = RedirectConfig+ { redirectState :: AcidState RedirectState+ , redirectClckURL :: ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text+ }++type RedirectT m = ClckT RedirectURL (ReaderT RedirectConfig m)+type RedirectT' url m = ClckT url (ReaderT RedirectConfig m)+type RedirectM = ClckT RedirectURL (ReaderT RedirectConfig (ServerPartT IO))+type RedirectAdminM = ClckT RedirectAdminURL (ReaderT RedirectConfig (ServerPartT IO))+++runRedirectT :: RedirectConfig -> RedirectT m a -> ClckT RedirectURL m a+runRedirectT mc m = mapClckT f m+ where+ f r = runReaderT r mc++runRedirectT'' :: Monad m =>+ (RedirectURL -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> RedirectConfig+ -> RedirectT m a+ -> ClckT url m a+runRedirectT'' showRedirectURL stripeConfig m = ClckT $ withRouteT flattenURL $ unClckT $ runRedirectT stripeConfig $ m+ where+ flattenURL :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> (RedirectURL -> [(T.Text, Maybe T.Text)] -> T.Text))+ flattenURL _ u p = showRedirectURL u p+++-- withRouteClckT ?+flattenURLClckT :: (url1 -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> ClckT url1 m a+ -> ClckT url2 m a+flattenURLClckT showClckURL m = ClckT $ withRouteT flattenURL $ unClckT m+ where+ flattenURL _ = \u p -> showClckURL u p++clckT2RedirectT :: (Functor m, MonadIO m, MonadFail m, Typeable url1) =>+ ClckT url1 m a+ -> RedirectT m a+clckT2RedirectT m =+ do p <- plugins <$> get+ (Just clckShowFn) <- getPluginRouteFn p (pluginName clckPlugin)+ flattenURLClckT clckShowFn $ mapClckT addReaderT m+ where+ addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)+ addReaderT m =+ do (a, cs) <- lift m+ return (a, cs)++data RedirectFormError+ = RedirectCFE (CommonFormError [Input])+ | RedirectErrorInternal+ deriving Show++instance FormError RedirectFormError where+ type ErrorInputType RedirectFormError = [Input]+ commonFormError = RedirectCFE++instance (Functor m, Monad m) => EmbedAsChild (RedirectT m) RedirectFormError where+ asChild e = asChild (show e)++type RedirectForm = ClckFormT RedirectFormError RedirectM++instance (Monad m) => MonadReader RedirectConfig (RedirectT' url m) where+ ask = ClckT $ ask+ local f (ClckT m) = ClckT $ local f m++instance (Functor m, Monad m) => GetAcidState (RedirectT' url m) RedirectState where+ getAcidState =+ redirectState <$> ask++instance (IsName n TL.Text) => EmbedAsAttr RedirectM (Attr n RedirectURL) where+ asAttr (n := u) =+ do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict url))++instance (IsName n TL.Text) => EmbedAsAttr RedirectM (Attr n ClckURL) where+ asAttr (n := url) =+ do showFn <- redirectClckURL <$> ask+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict $ showFn url []))++{-+-- | 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 <- getPreProcessors (plugins clckState)+ (Just clckRouteFn) <- getPluginRouteFn (plugins clckState) (pluginName clckPlugin)+ (markup', clckState') <- liftIO $ runClckT clckRouteFn 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)++{-+-- | update the 'currentRedirect' field of 'ClckState'+setCurrentRedirect :: (MonadIO m) => RedirectId -> RedirectT m ()+setCurrentRedirect pid =+ modify $ \s -> s { pageCurrent = pid }+-}+-}
+ Clckwrks/Redirect/Plugin.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts, FlexibleInstances, OverloadedStrings #-}+module Clckwrks.Redirect.Plugin where++import Clckwrks ( ClckwrksConfig(clckTopDir), ClckState(plugins), ClckT(..), ClckURL, ClckPlugins, Theme+ , Role(..), ClckPluginsSt, addAdminMenu, addNavBarCallback, addPreProc, query, update+ )+import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))+import Clckwrks.Plugin (clckPlugin)+import Clckwrks.Redirect.Acid (RedirectState, initialRedirectState)+import Clckwrks.Redirect.Monad (RedirectConfig(..), runRedirectT)+import Clckwrks.Redirect.Route (routeRedirect)+import Clckwrks.Redirect.URL (RedirectURL(..), RedirectAdminURL(..))+import Clckwrks.Redirect.Types ()+import Control.Applicative ((<$>))+import Control.Monad.State (get)+import Data.Acid (AcidState)+import Data.Acid.Advanced (update', query')+import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom,)+import Data.Char (ord)+import Data.List (intersperse)+import Data.Monoid ((<>))+import Data.String (fromString)+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Numeric (showIntAtBase)+import Happstack.Server (ServerPartT, Response, seeOther, notFound, toResponse)+-- import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Web.Routes (toPathSegments, parseSegments, withRouteT, fromPathSegments)+import Web.Plugins.Core (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, addPostHook, addPluginRouteFn, initPlugin, getConfig, getPluginRouteFn)++redirectHandler :: (RedirectURL -> [(Text, Maybe Text)] -> Text)+ -> RedirectConfig+ -> ClckPlugins+ -> [Text]+ -> ClckT ClckURL (ServerPartT IO) Response+redirectHandler showRedirectURL redirectConfig plugins paths =+ case parseSegments fromPathSegments paths of+ (Left e) -> notFound $ toResponse (show e)+ (Right u) ->+ ClckT $ withRouteT flattenURL $ unClckT $ runRedirectT redirectConfig $ routeRedirect u+ where+ flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (RedirectURL -> [(Text, Maybe Text)] -> Text))+ flattenURL _ u p = showRedirectURL u p++redirectInit :: ClckPlugins+ -> IO (Maybe Text)+redirectInit plugins =+ do (Just redirectShowFn) <- getPluginRouteFn plugins (pluginName redirectPlugin)+ (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ mTopDir <- clckTopDir <$> getConfig plugins+ let basePath = maybe "_state" (\td -> td </> "_state") mTopDir -- FIXME+ redirectDir = maybe "_redirect" (\td -> td </> "_redirect") mTopDir++ irs <- initialRedirectState+ acid <- openLocalStateFrom (basePath </> "redirect") irs+ addCleanup plugins Always (createCheckpointAndClose acid)++ let redirectConfig = RedirectConfig { redirectState = acid+ , redirectClckURL = clckShowFn+ }++-- addPreProc plugins (redirectCmd acid redirectShowFn)+-- addNavBarCallback plugins (navBarCallback acid redirectShowFn)+ addHandler plugins (pluginName redirectPlugin) (redirectHandler redirectShowFn redirectConfig)+-- addPostHook plugins (migrateUACCT acid)++ return Nothing++addRedirectAdminMenu :: ClckT url IO ()+addRedirectAdminMenu =+ do p <- plugins <$> get+ -- (Just redirectShowURL) <- getPluginRouteFn p (pluginName redirectPlugin)+ addAdminMenu ( "Redirect/Rewrites"+ , [ (Set.fromList [Administrator, Editor], "Redirects", "")+ ]+ )+ pure ()+{-+ let newRedirectURL = pageShowURL (PageAdmin NewPage) []+ pagesURL = pageShowURL (PageAdmin Pages) []+ feedConfigURL = pageShowURL (PageAdmin EditFeedConfig) []+ addAdminMenu ("Pages/Posts"+ , [ (Set.fromList [Administrator, Editor], "New Page/Post" , newRedirectURL)+ , (Set.fromList [Administrator, Editor], "Edit Page/Post" , pagesURL)+ , (Set.fromList [Administrator, Editor], "Edit Feed Config", feedConfigURL)+ ]+ )+-}+redirectPlugin :: Plugin RedirectURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+redirectPlugin = Plugin+ { pluginName = "redirect"+ , pluginInit = redirectInit+ , pluginDepends = ["clck"]+ , pluginToPathSegments = toPathSegments+ , pluginPostHook = addRedirectAdminMenu+ }++plugin :: ClckPlugins -- ^ plugins+ -> Text -- ^ baseURI+ -> IO (Maybe Text)+plugin plugins baseURI =+ initPlugin plugins baseURI redirectPlugin++-- | initialize the redirect plugin+--+-- we can not use the standard `initPlugin` function for the redirect plugin because we want to intercept URLs higher up the chain.+initRedirectPlugin ::+ Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt -- ^ 'Plugins' handle+ -> Text -- ^ base URI to prepend to generated URLs+ -> IO (Maybe Text) -- ^ possible error message+initRedirectPlugin plugins baseURI =+ do -- putStrLn $ "initializing " ++ (Text.unpack pluginName)+ let (Plugin{..}) = redirectPlugin+ addPluginRouteFn plugins pluginName baseURI pluginToPathSegments -- (\u p -> {- <> "/" <> {- pluginToPathInfo u <> -} paramsToQueryString (map (\(k, v) -> (k, fromMaybe mempty v)) p)-})+ addPostHook plugins pluginPostHook+ pluginInit plugins++paramsToQueryString :: [(Text, Text)] -> Text+paramsToQueryString [] = mempty+paramsToQueryString ps = toStrictText $ "?" <> mconcat (intersperse "&" (map paramToQueryString ps) )+ where+ toStrictText = toStrict . toLazyText++ isAlphaChar :: Char -> Bool+ isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')++ isDigitChar :: Char -> Bool+ isDigitChar c = (c >= '0' && c <= '9')++ isOk :: Char -> Bool+ isOk c = isAlphaChar c || isDigitChar c || elem c (":@$-_.~" :: String)++ escapeChar c+ | c == ' ' = singleton '+'+ | isOk c = singleton c+ | otherwise = "%" <>+ let hexDigit n+ | n <= 9 = head (show n)+ | n == 10 = 'A'+ | n == 11 = 'B'+ | n == 12 = 'C'+ | n == 13 = 'D'+ | n == 14 = 'E'+ | n == 15 = 'F'+ in case showIntAtBase 16 hexDigit (ord c) "" of+ [] -> "00"+ [x] -> fromString ['0',x]+ cs -> fromString cs++ escapeParam :: Text -> Builder+ escapeParam p = Text.foldr (\c cs -> escapeChar c <> cs) mempty p++ paramToQueryString :: (Text, Text) -> Builder+ paramToQueryString (k,v) = (escapeParam k) <> "=" <> (escapeParam v)
+ Clckwrks/Redirect/Route.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+module Clckwrks.Redirect.Route where++import Clckwrks (Role(..), requiresRole_)+import Clckwrks.Monad ( ClckState(plugins), query+ , update, setUnique, themeTemplate, nestURL+ )+--import Clckwrks.Page.Types (Page(..), PageId(..), toSlug)+--import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..), PageById(..))+-- import Clckwrks.Page.Admin.EditFeedConfig (editFeedConfig)+--- import Clckwrks.Page.Admin.EditPage (editPage)+--import Clckwrks.Page.Admin.NewPage (newPage)+--import Clckwrks.Page.Admin.Pages (pages)+--import Clckwrks.Page.Admin.PreviewPage (previewPage)+--import Clckwrks.Page.Atom (handleAtomFeed)+import Clckwrks.Redirect.Monad (RedirectConfig(redirectClckURL), RedirectM, clckT2RedirectT)+--import Clckwrks.Page.Types (PageKind(PlainPage, Post))+-- import Clckwrks.Page.BlogPage (blog)+import Clckwrks.Redirect.URL (RedirectURL(..), RedirectAdminURL(..))+import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.State (get)+import Data.Text (Text)+import qualified Data.Set as Set+import Happstack.Server ( Response, Happstack, escape, notFound, toResponse+ , ok, internalServerError+ )+import HSP.XMLGenerator (unXMLGenT)+import Web.Routes.Happstack (seeOtherURL)+import Web.Plugins.Core (getTheme)+{-+checkAuth :: RedirectURL+ -> RedirectM RedirectURL+checkAuth url =+ do showFn <- pageClckURL <$> ask+ let requiresRole = requiresRole_ showFn+ case url of+ + ViewPage{} -> return url+ ViewPageSlug{} -> return url+ Blog{} -> return url+ AtomFeed{} -> return url+ PageAdmin {} -> requiresRole (Set.singleton Administrator) url++-- | routes for 'AdminURL'+routePageAdmin :: PageAdminURL -> PageM Response+routePageAdmin url =+ case url of+ (EditPage pid) -> editPage (PageAdmin url) pid+ NewPage -> newPage PlainPage+ NewPost -> newPage Post+ (PreviewPage pid) -> previewPage pid -- FIXME+ EditFeedConfig -> editFeedConfig (PageAdmin url)+ Pages -> pages+-}+routeRedirect :: RedirectURL+ -> RedirectM Response+routeRedirect url' = ok $ toResponse ("foo" :: String)+{-+ 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 cs <- get+ (Just page) <- query (PageById pid)+ let ttl = pageTitle page+ bdy <- markupToContent (pageSrc page)+ clckT2PageT $ themeTemplate (plugins cs) (pageThemeStyleId page) ttl () bdy+ else do notFound $ toResponse ("Invalid PageId " ++ show (unPageId pid))++ (Blog) -> blog++ AtomFeed ->+ do handleAtomFeed++ (PageAdmin adminURL) -> routePageAdmin adminURL+-}
+ Clckwrks/Redirect/Types.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+module Clckwrks.Redirect.Types where++import Clckwrks (UserId(..))+import Clckwrks.Markup.HsColour (hscolour)+import Clckwrks.Markup.Markdown (markdown)+import Clckwrks.Markup.Pandoc (pandoc)+import Clckwrks.Monad (ThemeStyleId(..))+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 (IsString, 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 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_1+ = HsColour_1+ | Markdown_1+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''PreProcessor_1)++data PreProcessor+ = HsColour+ | Markdown+ | Pandoc+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''PreProcessor)++instance Migrate PreProcessor where+ type MigrateFrom PreProcessor = PreProcessor_1+ migrate HsColour_1 = HsColour+ migrate Markdown_1 = Markdown++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+ Pandoc -> pandoc Nothing trust+ 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)++publishStatusString :: PublishStatus -> String+publishStatusString Draft = "draft"+publishStatusString Revoked = "revoked"+publishStatusString Published = "published"+publishStatusString Scheduled = "scheduled"+++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_3 = Page_3+ { pageId_3 :: PageId+ , pageAuthor_3 :: UserId+ , pageTitle_3 :: Text+ , pageSlug_3 :: Maybe Slug+ , pageSrc_3 :: Markup+ , pageExcerpt_3 :: Maybe Markup+ , pageDate_3 :: UTCTime+ , pageUpdated_3 :: UTCTime+ , pageStatus_3 :: PublishStatus+ , pageKind_3 :: PageKind+ , pageUUID_3 :: UUID+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 3 'extension ''Page_3)++instance Migrate Page_3 where+ type MigrateFrom Page_3 = Page_002+ migrate (Page_002 pi pa pt ps pe pd pu pst pk puu) =+ (Page_3 pi pa pt Nothing ps pe pd pu pst pk puu)++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+ , pageThemeStyleId :: ThemeStyleId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 4 'extension ''Page)++-- migration added for clckwrks-plugin-page-0.3.0 on 2013-12-26+instance Migrate Page where+ type MigrateFrom Page = Page_3+ migrate (Page_3 pi pa pt psl ps pe pd pu pst pk puu) =+ (Page pi pa pt psl ps pe pd pu pst pk puu (ThemeStyleId 0))++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/Redirect/URL.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+module Clckwrks.Redirect.URL where++import Data.Data (Data, Typeable)+import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy)+import Clckwrks.Redirect.Acid ()+import Clckwrks.Redirect.Types ()+import Web.Routes.TH (derivePathInfo)++data RedirectAdminURL+ = EditRedirects+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''RedirectAdminURL)+$(derivePathInfo ''RedirectAdminURL)++data RedirectURL+ = Redirect+ deriving (Eq, Ord, Data, Typeable, Read, Show)+$(deriveSafeCopy 0 'base ''RedirectURL)+$(derivePathInfo ''RedirectURL)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++hsx2hsProgram = simpleProgram "hsx2hs"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [hsx2hsProgram]+ }
+ clckwrks-plugin-redirect.cabal view
@@ -0,0 +1,79 @@+name: clckwrks-plugin-redirect+version: 0.0.1+synopsis: support redirects for CMS/Blogging in clckwrks+description: This allows you to create custom url redirects as well as internal rewrites+homepage: http://www.clckwrks.com/+license: BSD3+license-file: LICENSE+copyright: 2016 Jeremy Shaw, SeeReason Partners LLC+author: Jeremy Shaw+maintainer: jeremy@n-heptane.com+category: Clckwrks+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.3, GHC == 8.8.3, GHC == 8.10.1++source-repository head+ type: git+ location: git://github.com/clckwrks/clckwrks-plugin-redirect.git++flag test-server+ Description: Enable the simple clckwrks site using the redirect plugin+ Default: False+ Manual: True++library+ Default-Language: Haskell2010+ exposed-modules: Clckwrks.Redirect.Acid+ Clckwrks.Redirect.Monad+ Clckwrks.Redirect.Plugin+ Clckwrks.Redirect.Route+ Clckwrks.Redirect.Types+ Clckwrks.Redirect.URL+++ build-depends: base >= 4.3 && < 4.15,+ acid-state >= 0.12 && < 0.17,+ aeson >= 1.3 && < 1.6,+ attoparsec >= 0.10 && < 0.14,+ clckwrks >= 0.21 && < 0.27,+ containers >= 0.4 && < 0.7,+ happstack-hsp >= 7.2 && < 7.4,+ happstack-server >= 7.0 && < 7.7,+ hsp >= 0.9 && < 0.11,+ hsx2hs >= 0.13 && < 0.15,+ ixset >= 1.0 && < 1.2,+ filepath,+ mtl >= 2.0 && < 2.3,+ old-locale == 1.0.*,+ random >= 1.0 && < 1.3,+ reform == 0.2.*,+ reform-happstack == 0.2.*,+ reform-hsp == 0.2.*,+ safecopy >= 0.8,+ text >= 0.11 && < 1.3,+ template-haskell >= 2.7 && <= 2.17,+ uuid >= 1.2 && <= 1.4,+ uuid-orphans >= 1.2 && < 1.5,+ web-plugins >= 0.4 && < 0.5,+ web-routes == 0.27.*,+ web-routes-happstack == 0.23.*,+ web-routes-th == 0.22.*++executable test-server+ Default-Language: Haskell2010+ if flag(test-server)+ Buildable: True+ else+ Buildable: False+ ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-I0+ Main-Is: Test.hs+ hs-source-dirs: test+ Build-Depends:+ base,+ clckwrks,+ clckwrks-plugin-page,+ clckwrks-theme-bootstrap,+ clckwrks-plugin-redirect,+ text,+ web-plugins
+ test/Test.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts, PackageImports, OverloadedStrings #-}+module Main where++import Clckwrks (ClckwrksConfig(..), ClckState, plugins)+import Clckwrks.Authenticate.Plugin (authenticatePlugin)+import Clckwrks.GetOpts (parseArgs, clckwrksOpts)+import Clckwrks.Server (simpleClckwrks)+import Clckwrks.Plugin (clckPlugin)+import Clckwrks.Page.Plugin (pagePlugin)+import Clckwrks.Redirect.Plugin (redirectPlugin)+import Data.Text (Text)+import Web.Plugins.Core (Rewrite(..), initPlugin, setRewriteFn, setTheme)+import System.Environment (getArgs)+-- we use 'PackageImports' because the 'Theme' module is supplied by multiple packages+import "clckwrks-theme-bootstrap" Theme (theme)+-- import Theme (theme)++------------------------------------------------------------------------------+-- ClckwrksConfig+------------------------------------------------------------------------------++-- | default configuration. Most of these options can be overridden on+-- the command-line accept for 'clckInitHook'.+clckwrksConfig :: ClckwrksConfig+clckwrksConfig = ClckwrksConfig+ { clckHostname = "localhost" -- hostname of the server+ , clckHidePort = False -- should the port number be used in generated URLs+ , clckPort = 8000 -- port to listen on+ , clckTLS = Nothing -- disable TLS by default+ , clckJQueryPath = "/usr/share/javascript/jquery" -- directory containing 'jquery.js'+ , clckJQueryUIPath = "" -- directory containing 'jquery.js'+ , clckJSTreePath = "/usr/share/clckwrks/jstree" -- directory containing 'jquery.jstree.js'+ , clckJSON2Path = "/usr/share/clckwrks/json2" -- directory containing 'json2.js'+ , clckTopDir = Nothing -- directory to store database, uploads, and other files+ , clckEnableAnalytics = False -- enable Google Analytics+ , clckInitHook = initHook -- init hook that loads theme and plugins+ }++------------------------------------------------------------------------------+-- initHook+------------------------------------------------------------------------------++-- | This 'initHook' is used as the 'clckInitHook' field in+-- 'ClckwrksConfig'.+--+-- It will be called automatically by 'simpleClckwrks'. This hook+-- provides an opportunity to explicitly load a theme and some+-- plugins.+--+-- Note that the we generally always init 'clckPlugin' here.+initHook :: Text -- ^ baseURI, e.g. http://example.org+ -> ClckState -- ^ current 'ClckState'+ -> ClckwrksConfig -- ^ the 'ClckwrksConfig'+ -> IO (ClckState, ClckwrksConfig)+initHook baseURI clckState cc =+ do let p = plugins clckState+ initPlugin p "" clckPlugin+ initPlugin p "" redirectPlugin+ setRewriteFn p (Just $ (pure rewriteFilter, pure unRewriteFilter))+ initPlugin p "http://localhost:8000" authenticatePlugin+ initPlugin p "" pagePlugin+ setTheme p (Just theme)+ return (clckState, cc)+ where+ rewriteFilter :: [Text] -> [(Text, Maybe Text)] -> Maybe (Rewrite, [Text], [(Text, Maybe Text)])+ rewriteFilter ["login"] params = Just (Rewrite, ["authenticate","login"], params)+ rewriteFilter ["admin"] params = Just (Rewrite, ["clck","admin", "console"], params)+ rewriteFilter ["settings"] params = Just(Redirect Nothing, ["clck","admin","edit-settings"], params)+ rewriteFilter ["clckwrks"] params = Just( Redirect (Just "http://www.clckwrks.com"), [], params)+ rewriteFilter paths params = Nothing++ unRewriteFilter :: [Text] -> [(Text, Maybe Text)] -> Maybe ([Text], [(Text, Maybe Text)])+ unRewriteFilter ["authenticate","login"] params = Just (["login"], params)+ unRewriteFilter ["clck","admin", "console"] params = Just (["admin"], params)+ unRewriteFilter paths params = Just (paths, params)++------------------------------------------------------------------------------+-- main+------------------------------------------------------------------------------++main :: IO ()+main =+ do args <- getArgs+ f <- parseArgs (clckwrksOpts clckwrksConfig) args+ putStrLn $ "listening on " ++ show (clckPort clckwrksConfig)+ simpleClckwrks =<< f clckwrksConfig