[clckwrks-0.11.0: added page slugs
Jeremy Shaw <jeremy@seereason.com>**20120810201438
 Ignore-this: 1177e49c4bd4a987483bd431e97a2359
] hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 12
-import Data.Maybe              (isJust)
+import Data.Maybe              (isJust, maybe)
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 14
+import qualified Data.Text     as Text
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 42
-               VisitPage    -> seeOtherURL (ViewPage    (pageId page))
+               VisitPage    -> seeOtherURL (ViewPageSlug (pageId page) (toSlug (pageTitle page) (pageSlug page)))
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 49
-       ol $ (,,,,,,)
+       ol $ (,,,,,,,)
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 53
+              <*> ((li $ label "slug (optional):") ++> (li $ inputText (maybe Text.empty unSlug $ pageSlug page) `setAttrs` ("size" := "80") ))
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 64
-      toPage :: (MonadIO m) => (Bool, PageKind, Text, Text, Maybe Text, Maybe Text, Maybe PublishStatus) -> m (Either ClckFormError (Page, AfterSaveAction))
-      toPage (haskell, kind, ttl, bdy, msave, mpreview, mpagestatus) =
+      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) =
hunk ./clckwrks/Clckwrks/Admin/EditPage.hs 71
+                      , pageSlug    = if Text.null slug then Nothing else Just (slugify slug)
hunk ./clckwrks/Clckwrks/Admin/Pages.hs 8
+import Clckwrks.Page.Types     (Slug(..))
hunk ./clckwrks/Clckwrks/Admin/Pages.hs 17
-editList ::  [(PageId, Text)] -> GenChildList (Clck AdminURL)
+editList ::  [(PageId, Text, Maybe Slug)] -> GenChildList (Clck AdminURL)
hunk ./clckwrks/Clckwrks/Admin/Pages.hs 27
-      editPageLI :: (PageId, Text) -> GenXML (Clck AdminURL)
-      editPageLI (pid, ttl) =
+      editPageLI :: (PageId, Text, Maybe Slug) -> GenXML (Clck AdminURL)
+      editPageLI (pid, ttl, _slug) =
hunk ./clckwrks/Clckwrks/Menu/Edit.hs 10
+import Clckwrks.Page.Types     (Slug(..), slugify)
hunk ./clckwrks/Clckwrks/Menu/Edit.hs 110
-addPageMenu :: [(PageId, Text)] -> JStat
+addPageMenu :: [(PageId, Text, Maybe Slug)] -> JStat
hunk ./clckwrks/Clckwrks/Menu/Edit.hs 138
-      summaryData (PageId pid, ttl)  =
+      summaryData (PageId pid, ttl, slug)  =
hunk ./clckwrks/Clckwrks/Menu/Types.hs 83
-data MenuItem url = MenuItem 
+data MenuItem url = MenuItem
hunk ./clckwrks/Clckwrks/Page/API.hs 8
+    , getPageTitleSlug
hunk ./clckwrks/Clckwrks/Page/API.hs 28
+import Clckwrks.Page.Types (toSlug)
hunk ./clckwrks/Clckwrks/Page/API.hs 48
+getPageTitleSlug :: Clck url (Text, Maybe Slug)
+getPageTitleSlug =
+    do p <- getPage
+       return (pageTitle p, pageSlug p)
+
hunk ./clckwrks/Clckwrks/Page/API.hs 58
-getPagesSummary :: Clck url [(PageId, Text)]
+getPagesSummary :: Clck url [(PageId, Text, Maybe Slug)]
hunk ./clckwrks/Clckwrks/Page/API.hs 67
-                <% mapM (\(pid, ttl) -> <li><a href=(ViewPage pid) title=ttl><% ttl %></a></li>) ps %>
+                <% mapM (\(pid, ttl, slug) -> <li><a href=(ViewPageSlug pid (toSlug ttl slug)) title=ttl><% ttl %></a></li>) ps %>
hunk ./clckwrks/Clckwrks/Page/Acid.hs 22
-import Clckwrks.Page.Types  (Markup(..), PublishStatus(..), PreProcessor(..), PageId(..), PageKind(..), Page(..), Pages(..), FeedConfig(..), initialFeedConfig)
+import Clckwrks.Page.Types  (Markup(..), PublishStatus(..), PreProcessor(..), PageId(..), PageKind(..), Page(..), Pages(..), FeedConfig(..), Slug(..), initialFeedConfig, slugify)
hunk ./clckwrks/Clckwrks/Page/Acid.hs 90
+                                                    , pageSlug      = Just $ slugify "This title rocks!"
hunk ./clckwrks/Clckwrks/Page/Acid.hs 113
-getPageTitle :: PageId -> Query PageState (Maybe Text)
-getPageTitle pid = fmap pageTitle <$> pageById pid
+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)
hunk ./clckwrks/Clckwrks/Page/Acid.hs 128
-pagesSummary :: Query PageState [(PageId, Text)]
+pagesSummary :: Query PageState [(PageId, Text, Maybe Slug)]
hunk ./clckwrks/Clckwrks/Page/Acid.hs 131
-       return $ map (\page -> (pageId page, pageTitle page)) (toList pgs)
+       return $ map (\page -> (pageId page, pageTitle page, pageSlug page)) (toList pgs)
hunk ./clckwrks/Clckwrks/Page/Acid.hs 148
+                       , pageSlug    = Nothing
hunk ./clckwrks/Clckwrks/Page/Atom.hs 52
-                   <link href=(ViewPage $ pageId) />
+                   <link href=(ViewPageSlug pageId (toSlug pageTitle pageSlug)) />
hunk ./clckwrks/Clckwrks/Page/PreProcess.hs 8
-import Clckwrks.URL   (ClckURL(ViewPage))
-import Clckwrks.Page.Types (PageId(..))
+import Clckwrks.URL   (ClckURL(ViewPageSlug))
+import Clckwrks.Page.Types (PageId(..), slugify, toSlug)
hunk ./clckwrks/Clckwrks/Page/PreProcess.hs 58
-                   do ttl <- case mTitle of
-                               (Just t) -> return t
-                               Nothing  -> do mttl <- query (GetPageTitle pid)
-                                              case mttl of
-                                                Nothing -> return $ pack "Untitled"
-                                                (Just ttl) -> return ttl
-                      html <- unXMLGenT $ <a href=(showURLFn (ViewPage pid) [])><% ttl %></a>
+                   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=(showURLFn (ViewPageSlug pid (toSlug ttl slug)) [])><% ttl %></a>
hunk ./clckwrks/Clckwrks/Page/Types.hs 1
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies #-}
hunk ./clckwrks/Clckwrks/Page/Types.hs 7
-import Control.Applicative      ((<$>))
+import Control.Applicative      ((<$>), optional)
hunk ./clckwrks/Clckwrks/Page/Types.hs 10
-import Data.Char                (ord)
+import Data.Char                (ord, toLower, isAlphaNum)
hunk ./clckwrks/Clckwrks/Page/Types.hs 17
+import qualified Data.Text      as Text
hunk ./clckwrks/Clckwrks/Page/Types.hs 23
-import Web.Routes               (PathInfo(..))
+import Web.Routes               (PathInfo(..), anySegment)
hunk ./clckwrks/Clckwrks/Page/Types.hs 26
+
hunk ./clckwrks/Clckwrks/Page/Types.hs 110
+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
hunk ./clckwrks/Clckwrks/Page/Types.hs 155
+           , pageSlug      :: Maybe Slug
hunk ./clckwrks/Clckwrks/Page/Types.hs 165
-$(deriveSafeCopy 2 'extension ''Page)
+$(deriveSafeCopy 3 'extension ''Page)
hunk ./clckwrks/Clckwrks/Page/Types.hs 168
-    type MigrateFrom Page = Page_001
-    migrate (Page_001 pi pt ps pe pd pst pk) =
-        (Page 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
+    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)
hunk ./clckwrks/Clckwrks/Server.hs 7
-import Clckwrks.Page.Acid          (IsPublishedPage(..))
+import Clckwrks.Page.Acid          (GetPageTitle(..), IsPublishedPage(..))
hunk ./clckwrks/Clckwrks/Server.hs 87
+      ViewPageSlug{}       -> return url
hunk ./clckwrks/Clckwrks/Server.hs 104
+           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) ->
hunk ./clckwrks/Clckwrks/Server.hs 150
-clckSite cc clckState = setDefault (ViewPage $ PageId 1) $ mkSitePI route'
+clckSite cc clckState = setDefault (ViewPageSlug (PageId 1) (Slug Text.empty)) $ mkSitePI route'
hunk ./clckwrks/Clckwrks/URL.hs 1
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}
hunk ./clckwrks/Clckwrks/URL.hs 14
+import Clckwrks.Page.Types         (Slug(..))
hunk ./clckwrks/Clckwrks/URL.hs 17
-import Data.SafeCopy               (SafeCopy(..), base, deriveSafeCopy)
+import Data.SafeCopy               (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension)
hunk ./clckwrks/Clckwrks/URL.hs 21
-
hunk ./clckwrks/Clckwrks/URL.hs 23
+data ClckURL_1
+    = ViewPage_1 PageId
+    | Blog_1
+    | AtomFeed_1
+    | ThemeData_1 FilePath
+    | PluginData_1 Text FilePath
+    | Admin_1 AdminURL
+    | Profile_1 ProfileDataURL
+    | Auth_1 AuthProfileURL
+      deriving (Eq, Ord, Data, Typeable, Read, Show)
+$(deriveSafeCopy 1 'base ''ClckURL_1)
+
hunk ./clckwrks/Clckwrks/URL.hs 37
+    | ViewPageSlug PageId Slug
hunk ./clckwrks/Clckwrks/URL.hs 46
+$(deriveSafeCopy 2 'extension ''ClckURL)
+
+instance Migrate ClckURL where
+    type MigrateFrom ClckURL   = ClckURL_1
+    migrate (ViewPage_1 pid)   = ViewPage pid
+    migrate Blog_1             = Blog
+    migrate AtomFeed_1         = AtomFeed
+    migrate (ThemeData_1 fp)   = ThemeData fp
+    migrate (PluginData_1 t f) = PluginData t f
+    migrate (Admin_1 u)        = Admin u
+    migrate (Profile_1 pdu)    = Profile pdu
+    migrate (Auth_1 apu)       = Auth apu
hunk ./clckwrks/Clckwrks/URL.hs 63
-$(deriveSafeCopy 1 'base ''ClckURL)
hunk ./clckwrks/Clckwrks/URL.hs 67
+
hunk ./clckwrks/clckwrks.cabal 2
-Version:             0.10.1
+Version:             0.11.0