diff --git a/multiblog.cabal b/multiblog.cabal index aba4a0e..ef5511a 100644 --- a/multiblog.cabal +++ b/multiblog.cabal @@ -17,10 +17,12 @@ Executable multiblog Build-depends: blaze-html >= 0.7, + blaze-markup >= 0.6, boomerang >= 1.4, bytestring >= 0.10, containers >= 0.5, directory >= 1.2, + feed >= 0.3, filepath >= 1.3, happstack >= 7.0, happstack-server >= 7.3, @@ -64,6 +66,7 @@ Test-Suite tests shakespeare >= 2.0, split >= 0.2, time >= 1.4 && < 1.6, + xml >= 1.3, derive >= 2.5, HTF >= 0.12, HUnit >= 1.2, diff --git a/src/App.hs b/src/App.hs index 0f2ed0b..33ab83c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -21,24 +21,28 @@ import Models import Routes import Utils import Views +import Views.Feed -- TODO: This should be a ReaderT type App = StateT AppState IO type AppPart a = RouteT Sitemap (ServerPartT App) a -loadApp :: String -> IO AppState -loadApp dataDirectory = do +loadApp :: String -- directory to load from + -> String -- site address + -> IO AppState +loadApp dataDirectory siteAddress = do app <- loadFromDirectory dataDirectory case app of Left err -> error err - Right appState -> return appState + Right appState -> return appState { appAddress = siteAddress } runApp :: AppState -> App a -> IO a runApp app a = evalStateT a app -site :: String -> ServerPartT App Response -site address = do +site :: ServerPartT App Response +site = do + address <- lift $ gets appAddress appDir <- lift $ gets appDirectory let routedSite = boomerangSiteRouteT handler sitemap let staticSite = serveDirectory DisableBrowsing [] $ appDir ++ "/static" @@ -52,6 +56,7 @@ handler route = case route of Daily d -> dailyIndex d ArticleView d s -> article d s MetaView s -> meta s + Feed lang -> feedIndex lang index :: AppPart Response index = articleList $ const True @@ -96,3 +101,9 @@ meta slug = do language <- languageHeaderM m <- getMeta slug metaDisplay language m >>= html + +feedIndex :: Language -> AppPart Response +feedIndex language = do + articles <- lift $ getFiltered (const True) + let sorted = sortBy reverseCompare articles + feedDisplay language sorted >>= html diff --git a/src/Import.hs b/src/Import.hs index e939f61..b6b9dc3 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -100,7 +100,7 @@ loadFromDirectory path = do return $ do state <- fromSources sources strings <- loadStrings stringsFile - return $ state { appDirectory = path, appStrings = strings } + return $ state { appDirectory = path, appStrings = strings, appAddress = "" } -- All content sources from a directory sourcesFromDirectory :: FilePath -> IO [ContentSource] @@ -134,6 +134,7 @@ fromSources sources = do extracted <- mapM makeArticle grouped let (articles, meta) = partitionEithers extracted return AppState { appDirectory = "" + , appAddress = "" , appArticles = articles , appMeta = meta , appStrings = M.empty diff --git a/src/Language.hs b/src/Language.hs index bd23c70..e117bb3 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -5,6 +5,7 @@ module Language where import Control.Applicative import Control.Monad +import Data.Function import Data.LanguageCodes import Data.List import Data.List.Split @@ -12,6 +13,8 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Yaml as Y +import Utils + type Language = ISO639_1 @@ -33,6 +36,9 @@ defaultLanguage = EN singleLanguage :: Language -> LanguagePreference singleLanguage lang = LanguagePreference $ M.singleton lang 1 +bestLanguage :: LanguagePreference -> Language +bestLanguage = fst . head . sortBy (reverseCompare `on` snd) . M.toList . unLanguagePreference + rankLanguage :: Language -> LanguagePreference -> Float rankLanguage lang = fromMaybe 0 . M.lookup lang . unLanguagePreference @@ -50,6 +56,9 @@ parseLanguage [c1, c2] = case fromChars c1 c2 of Nothing -> mzero parseLanguage _ = mzero +showLanguage :: Language -> String +showLanguage = (\(a, b) -> a:b:[]) . toChars + -- TODO: Parsec or library languageHeader :: Maybe String -> LanguagePreference languageHeader Nothing = LanguagePreference $ M.singleton defaultLanguage 1 @@ -62,6 +71,5 @@ languageHeader (Just str) = LanguagePreference $ M.fromList $ mapMaybe parsePref instance Show LanguagePreference where show = intercalate "," . map (uncurry showPref) . M.toList . unLanguagePreference - where showPref lang 1 = languageStr lang - showPref lang qvalue = languageStr lang ++ ";q=" ++ show qvalue - languageStr = (\(a, b) -> a:b:[]) . toChars + where showPref lang 1 = showLanguage lang + showPref lang qvalue = showLanguage lang ++ ";q=" ++ show qvalue diff --git a/src/Main.hs b/src/Main.hs index 9bceed5..cb077d9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -55,13 +55,13 @@ listenPort = liftM (read . fromMaybe "8000") (lookupEnv "LISTEN_PORT") -- Run the actual site runSite :: IO () runSite = do - -- TODO: parametrise? - app <- loadApp "content" address <- siteAddress + -- TODO: directory name as parameter? + app <- loadApp "content" address lport <- listenPort let conf = nullConf { port = lport } -- Manually bind the socket to close it on exception bracket (bindPort conf) close - (\sock -> simpleHTTPWithSocket' (runApp app) sock conf $ site address) + (\sock -> simpleHTTPWithSocket' (runApp app) sock conf site) diff --git a/src/Models.hs b/src/Models.hs index 2c4d9e5..0ee11dd 100644 --- a/src/Models.hs +++ b/src/Models.hs @@ -53,6 +53,7 @@ instance HasSlug Meta where getSlug = mtSlug data AppState = AppState { appDirectory :: String + , appAddress :: String , appArticles :: [Article] , appMeta :: [Meta] , appStrings :: M.Map String (LanguageMap String) diff --git a/src/Routes.hs b/src/Routes.hs index 36f7cd8..8b45d25 100644 --- a/src/Routes.hs +++ b/src/Routes.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} module Routes where import Prelude hiding ((.)) @@ -14,12 +15,15 @@ import Text.Boomerang.TH (makeBoomerangs) import Web.Routes.Boomerang +import Language + data Sitemap = Index | Yearly Integer | Monthly Integer Int | Daily Day | ArticleView Day String | MetaView String + | Feed Language deriving (Eq, Show) makeBoomerangs ''Sitemap @@ -29,6 +33,12 @@ rDay = xpure mkDay parseDay . (integer > int > int) where mkDay (y :- m :- d :- x) = fromGregorian y m d :- x parseDay (day :- x) = let (y, m, d) = toGregorian day in Just $ y :- m :- d :- x +-- TODO: This will error on strings which are not language codes +rLanguage :: Boomerang TextsError [T.Text] r (Language :- r) +rLanguage = xpure mkLang parseLang . anyString + where mkLang (str :- x) = let Just lang = parseLanguage str in lang :- x + parseLang (lang :- x) = Just $ showLanguage lang :- x + rString :: Boomerang e tok i (T.Text :- o) -> Boomerang e tok i (String :- o) rString = xmaph T.unpack (Just . T.pack) @@ -43,4 +53,5 @@ sitemap = mconcat , rDaily . rDay , rArticleView . rDay > anyString , rMetaView . anyString + , rFeed . "feed" > rLanguage ] diff --git a/src/Utils.hs b/src/Utils.hs index e1d9e14..58021de 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -37,4 +37,4 @@ isSpecial ".." = True isSpecial _ = False reverseCompare :: Ord a => a -> a -> Ordering -reverseCompare a b = compare b a +reverseCompare = flip compare diff --git a/src/Views.hs b/src/Views.hs index c6a0e8b..33f523b 100644 --- a/src/Views.hs +++ b/src/Views.hs @@ -54,13 +54,21 @@ render html = do route <- liftM convRender askRouteFn return $ html route +getLangStringFn :: MonadState AppState m => LanguagePreference -> m (String -> String) +getLangStringFn lang = do + strings <- gets appStrings + let fn str = fromMaybe str $ M.lookup str strings >>= matchLanguage lang + return fn + +getLangString :: MonadState AppState m => LanguagePreference -> String -> m String +getLangString lang str = getLangStringFn lang >>= (\fn -> return $ fn str) + template :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) => LanguagePreference -> PageContent (URL m) -> m Markup template lang page = do -- TODO: need to be able to get any meta inside about <- getMeta "about" - strings <- gets appStrings - let langString str = fromMaybe str $ M.lookup str strings >>= matchLanguage lang + langString <- getLangStringFn lang render $(hamletFile "templates/base.hamlet") articleListDisplay :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) => @@ -92,14 +100,21 @@ inlineToStr inline = writePlain def $ Pandoc undefined [Plain inline] langContent :: HasContent a => LanguagePreference -> a -> Pandoc langContent lang = fromJust . matchLanguage lang . getContent +-- Generate a link to some content +linkTo :: (Linkable a, MonadRoute m, URL m ~ Sitemap) + => a + -> m String +linkTo a = do + routeFn <- askRouteFn + return $ T.unpack $ routeFn (link a) [] + -- Modify the content to have a link to itself and have no anchors linkedContent :: (HasContent a, Linkable a, MonadRoute m, URL m ~ Sitemap) => LanguagePreference -> a -> m Pandoc linkedContent lang a = do - routeFn <- askRouteFn - let target = T.unpack $ routeFn (link a) [] + target <- linkTo a return $ linkedHeader target $ langContent lang a -- Modify the first header to be a link to a given place diff --git a/src/Views/Feed.hs b/src/Views/Feed.hs new file mode 100644 index 0000000..a61726c --- /dev/null +++ b/src/Views/Feed.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Views.Feed where + +import Control.Monad.State + +import Data.Time + +import Text.Atom.Feed (Date, Entry (..), EntryContent (..), Feed (..), + TextContent (..), nullEntry, nullFeed, nullLink) +import Text.Atom.Feed.Export (xmlFeed) + +import Text.Blaze.Renderer.String (renderMarkup) + +import Text.Pandoc (def, writeHtml) + +import Text.XML.Light.Output (showTopElement) + +import Web.Routes + +import Language +import Models +import Routes +import Views + +-- TODO: show time properly when it's parsed +atomDate :: UTCTime -> Date +atomDate = (++ "T00:00:00Z") . showGregorian . utctDay + +articleEntry :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m) => Language -> Article -> m Entry +articleEntry lang article = do + let lpref = singleLanguage lang + articleLink <- linkTo article + let entry = nullEntry articleLink (TextString $ langTitle lpref article) (atomDate $ arAuthored article) + let content = renderMarkup $ writeHtml def $ langContent lpref article + return entry { entryContent = Just $ HTMLContent content + , entryLinks = [nullLink articleLink] + } + +feedDisplay :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) => + Language -> [Article] -> m String +feedDisplay lang articles = do + siteName <- getLangString (singleLanguage lang) "siteName" + siteId <- gets appAddress + let lastUpdated = arAuthored $ head articles + let blankFeed = nullFeed siteId (TextString siteName) (atomDate lastUpdated) + entries <- mapM (articleEntry lang) articles + let feed = blankFeed { feedEntries = entries } + return $ showTopElement $ xmlFeed feed diff --git a/templates/base.hamlet b/templates/base.hamlet index 01ef517..1623e51 100644 --- a/templates/base.hamlet +++ b/templates/base.hamlet @@ -9,6 +9,7 @@ $doctype 5 #{langString "siteName"} +