diff --git a/Clckwrks/Redirect/Acid.hs b/Clckwrks/Redirect/Acid.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/Acid.hs @@ -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 + ] diff --git a/Clckwrks/Redirect/Monad.hs b/Clckwrks/Redirect/Monad.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/Monad.hs @@ -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 } +-} +-} diff --git a/Clckwrks/Redirect/Plugin.hs b/Clckwrks/Redirect/Plugin.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/Plugin.hs @@ -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) diff --git a/Clckwrks/Redirect/Route.hs b/Clckwrks/Redirect/Route.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/Route.hs @@ -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 +-} diff --git a/Clckwrks/Redirect/Types.hs b/Clckwrks/Redirect/Types.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/Types.hs @@ -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" + } +-} diff --git a/Clckwrks/Redirect/URL.hs b/Clckwrks/Redirect/URL.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Redirect/URL.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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] + } diff --git a/clckwrks-plugin-redirect.cabal b/clckwrks-plugin-redirect.cabal new file mode 100644 --- /dev/null +++ b/clckwrks-plugin-redirect.cabal @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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