diff options
Diffstat (limited to 'services/tazblog')
| -rw-r--r-- | services/tazblog/src/Blog.hs | 72 | ||||
| -rw-r--r-- | services/tazblog/src/BlogStore.hs | 128 | ||||
| -rw-r--r-- | services/tazblog/src/Locales.hs | 19 | ||||
| -rw-r--r-- | services/tazblog/src/RSS.hs | 44 | ||||
| -rw-r--r-- | services/tazblog/src/Server.hs | 75 |
5 files changed, 187 insertions, 151 deletions
diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs index d02836a3f3ac..15ac9993eba4 100644 --- a/services/tazblog/src/Blog.hs +++ b/services/tazblog/src/Blog.hs @@ -1,26 +1,25 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Blog where import BlogStore -import Data.Text (Text, empty, pack) -import Data.Text.Lazy (fromStrict) -import Data.Time -import Locales -import Text.Blaze.Html (preEscapedToHtml) -import Text.Hamlet -import Text.Markdown - -import qualified Data.Text as T +import Data.Text (Text, empty, pack) +import qualified Data.Text as T +import Data.Text.Lazy (fromStrict) +import Data.Time +import Locales +import Text.Blaze.Html (preEscapedToHtml) +import Text.Hamlet +import Text.Markdown replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) @@ -29,9 +28,9 @@ replace x y = map (\z -> if z == x then y else z) markdownCutoff :: Day markdownCutoff = fromGregorian 2013 04 28 --- blog HTML blogTemplate :: BlogLang -> Text -> Html -> Html -blogTemplate lang t_append body = [shamlet| +blogTemplate lang t_append body = + [shamlet| $doctype 5 <head> <meta charset="utf-8"> @@ -48,11 +47,12 @@ $doctype 5 ^{body} ^{showFooter} |] - where - rssUrl = T.concat ["/", show' lang, "/rss.xml"] + where + rssUrl = T.concat ["/", show' lang, "/rss.xml"] showFooter :: Html -showFooter = [shamlet| +showFooter = + [shamlet| <footer> <p .footer>Served without any dynamic languages. <p .footer> @@ -72,7 +72,8 @@ renderEntryMarkdown :: Text -> Html renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict renderEntries :: [Entry] -> Maybe Html -> Html -renderEntries entries pageLinks = [shamlet| +renderEntries entries pageLinks = + [shamlet| $forall entry <- entries <article> <h2 .inline> @@ -93,10 +94,11 @@ $maybe links <- pageLinks ^{links} |] where - linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId] + linkElems Entry {..} = concat $ ["/", show lang, "/", show entryId] showLinks :: Maybe Int -> BlogLang -> Html -showLinks (Just i) lang = [shamlet| +showLinks (Just i) lang = + [shamlet| $if ((>) i 1) <div .navigation> <a href=#{nLink $ succ i} .uncoloured-link>#{backText lang} @@ -106,16 +108,18 @@ showLinks (Just i) lang = [shamlet| ^{showLinks Nothing lang} |] where - nLink page = T.concat ["/", show' lang, "/?page=", show' page] -showLinks Nothing lang = [shamlet| + nLink page = T.concat ["/", show' lang, "/?page=", show' page] +showLinks Nothing lang = + [shamlet| <div .navigation> <a href=#{nLink} .uncoloured-link>#{backText lang} |] where - nLink = T.concat ["/", show' lang, "/?page=2"] + nLink = T.concat ["/", show' lang, "/?page=2"] renderEntry :: Entry -> Html -renderEntry e@Entry{..} = [shamlet| +renderEntry e@Entry {..} = + [shamlet| <article> <h2 .inline> #{title} @@ -131,12 +135,16 @@ renderEntry e@Entry{..} = [shamlet| |] showError :: BlogError -> BlogLang -> Html -showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet| +showError NotFound l = + blogTemplate l (T.append ": " $ notFoundTitle l) + $ [shamlet| <p>:( <p>#{notFoundText l} <hr> |] -showError UnknownError l = blogTemplate l "" $ [shamlet| +showError UnknownError l = + blogTemplate l "" + $ [shamlet| <p>:( <p>#{unknownErrorText l} <hr> diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs index a91db060b825..0472fef56bc9 100644 --- a/services/tazblog/src/BlogStore.hs +++ b/services/tazblog/src/BlogStore.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + -- |This module implements fetching of individual blog entries from -- DNS. Yes, you read that correctly. -- @@ -15,49 +19,47 @@ -- -- This module implements logic for assembling a post out of these -- fragments and caching it based on the TTL of its `_meta` record. -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module BlogStore + ( BlogCache, + EntryId (..), + Entry (..), + withCache, + listEntries, + getEntry, + show' + ) +where -module BlogStore( - BlogCache, - EntryId(..), - Entry(..), - withCache, - listEntries, - getEntry, - show', -) where - -import Data.Aeson ((.:), FromJSON(..), Value(Object), decodeStrict) import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson ((.:), FromJSON (..), Value (Object), decodeStrict) +import Data.ByteString.Base64 (decodeLenient) +import Data.Either (fromRight) +import Data.List (sortBy) import Data.Text as T (Text, concat, pack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8') +import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time (Day) import Locales (BlogLang (..)) -import Network.DNS (lookupTXT, DNSError) +import Network.DNS (DNSError, lookupTXT) import qualified Network.DNS.Resolver as R -import Data.ByteString.Base64 (decodeLenient) -import Data.List (sortBy) -import Data.Either (fromRight) newtype EntryId = EntryId {unEntryId :: Integer} deriving (Eq, Ord, FromJSON) instance Show EntryId where + show = show . unEntryId data Entry = Entry { entryId :: EntryId, - lang :: BlogLang, - author :: Text, - title :: Text, - btext :: Text, - mtext :: Text, - edate :: Day + lang :: BlogLang, + author :: Text, + title :: Text, + btext :: Text, + mtext :: Text, + edate :: Day } deriving (Eq, Ord, Show) @@ -80,20 +82,22 @@ type Count = Int withCache :: Text -> (BlogCache -> IO a) -> IO a withCache zone f = do - let conf = R.defaultResolvConf { R.resolvCache = Just R.defaultCacheConf - , R.resolvConcurrent = True } + let conf = + R.defaultResolvConf + { R.resolvCache = Just R.defaultCacheConf, + R.resolvConcurrent = True + } seed <- R.makeResolvSeed conf R.withResolver seed $ (\r -> f $ BlogCache r zone) - listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry] listEntries cache offset count = liftIO $ do posts <- postList cache entries <- mapM (entryFromDNS cache) $ take count $ drop offset $ fromRight (error "no posts") posts - -- TODO: maybe don't just drop broken entries return - $ fromRight (error "no entries") $ sequence entries + $ fromRight (error "no entries") + $ sequence entries getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry) getEntry cache eid = liftIO $ (entryFromDNS cache eid) >>= \case @@ -104,7 +108,6 @@ show' :: Show a => a -> Text show' = pack . show -- * DNS fetching implementation - type Chunk = Integer -- | Represents the metadata stored for each post in the _meta record. @@ -112,23 +115,28 @@ data Meta = Meta Integer Text Day deriving (Show) instance FromJSON Meta where - parseJSON (Object v) = Meta <$> - v .: "c" <*> - v .: "t" <*> - v .: "d" + + parseJSON (Object v) = + Meta + <$> v + .: "c" + <*> v + .: "t" + <*> v + .: "d" parseJSON _ = mzero entryMetadata :: BlogCache -> EntryId -> IO (Either StoreError Meta) entryMetadata (BlogCache r z) (EntryId eid) = let domain = encodeUtf8 ("_meta." <> show' eid <> "." <> z) record = lookupTXT r domain - toMeta rrdata = case decodeStrict $ decodeLenient rrdata of + toMeta rrdata = case decodeStrict $ decodeLenient rrdata of Nothing -> Left InvalidMetadata - Just m -> Right m - in record >>= \case - (Left err) -> return $ Left $ DNS err - (Right [ bs ]) -> return $ toMeta bs - _ -> return $ Left InvalidMetadata + Just m -> Right m + in record >>= \case + (Left err) -> return $ Left $ DNS err + (Right [bs]) -> return $ toMeta bs + _ -> return $ Left InvalidMetadata entryChunk :: BlogCache -> EntryId -> Chunk -> IO (Either StoreError Text) entryChunk (BlogCache r z) (EntryId eid) c = @@ -137,14 +145,14 @@ entryChunk (BlogCache r z) (EntryId eid) c = toChunk rrdata = case decodeUtf8' $ decodeLenient rrdata of Left _ -> Left InvalidChunk Right chunk -> Right chunk - in record >>= \case - (Left err) -> return $ Left $ DNS err - (Right [ bs ]) -> return $ toChunk bs - _ -> return $ Left InvalidChunk + in record >>= \case + (Left err) -> return $ Left $ DNS err + (Right [bs]) -> return $ toChunk bs + _ -> return $ Left InvalidChunk fetchAssembleChunks :: BlogCache -> EntryId -> Meta -> IO (Either StoreError Text) fetchAssembleChunks cache eid (Meta n _ _) = do - chunks <- mapM (entryChunk cache eid) [0..(n - 1)] + chunks <- mapM (entryChunk cache eid) [0 .. (n - 1)] return $ either Left (Right . T.concat) $ sequence chunks entryFromDNS :: BlogCache -> EntryId -> IO (Either StoreError Entry) @@ -155,19 +163,25 @@ entryFromDNS cache eid = do Right meta -> do chunks <- fetchAssembleChunks cache eid meta let (Meta _ t d) = meta - return $ either Left (\text -> Right $ Entry { - entryId = eid, - lang = EN, - author = "tazjin", - title = t, - btext = text, - mtext = "", - edate = d}) chunks + return + $ either Left + ( \text -> Right $ Entry + { entryId = eid, + lang = EN, + author = "tazjin", + title = t, + btext = text, + mtext = "", + edate = d + } + ) + chunks postList :: BlogCache -> IO (Either StoreError [EntryId]) postList (BlogCache r z) = let domain = encodeUtf8 ("_posts." <> z) record = lookupTXT r domain - toPosts = fmap (sortBy (flip compare)) . sequence . - map (\r -> maybe (Left InvalidPosts) Right (decodeStrict r)) - in record >>= return . either (Left . DNS) toPosts + toPosts = + fmap (sortBy (flip compare)) . sequence + . map (\r -> maybe (Left InvalidPosts) Right (decodeStrict r)) + in record >>= return . either (Left . DNS) toPosts diff --git a/services/tazblog/src/Locales.hs b/services/tazblog/src/Locales.hs index 2e49809eee32..79edcd75f32a 100644 --- a/services/tazblog/src/Locales.hs +++ b/services/tazblog/src/Locales.hs @@ -1,17 +1,20 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Locales where -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Network.URI +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI data BlogLang = EN | DE - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show BlogLang where - show DE = "de" - show EN = "en" + + show DE = "de" + show EN = "en" data BlogError = NotFound | UnknownError diff --git a/services/tazblog/src/RSS.hs b/services/tazblog/src/RSS.hs index 02a2aafda969..d3e78ba0fb85 100644 --- a/services/tazblog/src/RSS.hs +++ b/services/tazblog/src/RSS.hs @@ -1,42 +1,48 @@ {-# LANGUAGE RecordWildCards #-} -module RSS (renderFeed) where -import qualified Data.Text as T +module RSS + ( renderFeed + ) +where +import BlogStore import Control.Monad (liftM) -import Data.Maybe (fromMaybe) -import Data.Time (UTCTime(..), getCurrentTime, secondsToDiffTime) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime) +import Locales import Network.URI import Text.RSS -import BlogStore -import Locales - createChannel :: BlogLang -> UTCTime -> [ChannelElem] -createChannel l now = [ Language $ show l - , Copyright "Vincent Ambo" - , WebMaster "tazjin@gmail.com" - , ChannelPubDate now - ] +createChannel l now = + [ Language $ show l, + Copyright "Vincent Ambo", + WebMaster "mail@tazj.in", + ChannelPubDate now + ] createRSS :: BlogLang -> UTCTime -> [Item] -> RSS createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) createItem :: Entry -> Item -createItem Entry{..} = [ Title $ T.unpack title - , Link $ makeLink lang entryId - , Description $ T.unpack btext - , PubDate $ UTCTime edate $ secondsToDiffTime 0 ] +createItem Entry {..} = + [ Title $ T.unpack title, + Link $ makeLink lang entryId, + Description $ T.unpack btext, + PubDate $ UTCTime edate $ secondsToDiffTime 0 + ] makeLink :: BlogLang -> EntryId -> URI -makeLink l i = let url = "http://tazj.in/" ++ show l ++ "/" ++ show i - in fromMaybe nullURI $ parseURI url +makeLink l i = + let url = "http://tazj.in/" ++ show l ++ "/" ++ show i + in fromMaybe nullURI $ parseURI url createItems :: [Entry] -> [Item] createItems = map createItem createFeed :: BlogLang -> [Entry] -> IO RSS -createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e ) +createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e) renderFeed :: BlogLang -> [Entry] -> IO String renderFeed l e = liftM (showXML . rssToXML) (createFeed l e) diff --git a/services/tazblog/src/Server.hs b/services/tazblog/src/Server.hs index 8a7384ccca3e..492849a2f39d 100644 --- a/services/tazblog/src/Server.hs +++ b/services/tazblog/src/Server.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} -module Server where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -import Control.Applicative (optional) -import Control.Monad (msum) -import Control.Monad.IO.Class (liftIO) -import Data.Char (toLower) -import qualified Data.Text as T -import Happstack.Server hiding (Session) -import Data.Maybe (maybe) +module Server where import Blog import BlogStore +import Control.Applicative (optional) +import Control.Monad (msum) +import Control.Monad.IO.Class (liftIO) +import Data.Char (toLower) +import Data.Maybe (maybe) +import qualified Data.Text as T +import Happstack.Server hiding (Session) import Locales import RSS @@ -19,7 +22,7 @@ instance FromReqURI BlogLang where case map toLower sub of "de" -> Just DE "en" -> Just EN - _ -> Nothing + _ -> Nothing pageSize :: Int pageSize = 3 @@ -34,21 +37,23 @@ runBlog port respath = do tazBlog :: BlogCache -> String -> ServerPart Response tazBlog cache resDir = do - msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang - , dir "static" $ staticHandler resDir - , blogHandler cache EN - , staticHandler resDir - , notFound $ toResponse $ showError NotFound DE - ] + msum + [ path $ \(lang :: BlogLang) -> blogHandler cache lang, + dir "static" $ staticHandler resDir, + blogHandler cache EN, + staticHandler resDir, + notFound $ toResponse $ showError NotFound DE + ] blogHandler :: BlogCache -> BlogLang -> ServerPart Response blogHandler cache lang = - msum [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId - , nullDir >> showIndex cache lang - , dir "rss" $ nullDir >> showRSS cache lang - , dir "rss.xml" $ nullDir >> showRSS cache lang - , notFound $ toResponse $ showError NotFound lang - ] + msum + [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId, + nullDir >> showIndex cache lang, + dir "rss" $ nullDir >> showRSS cache lang, + dir "rss.xml" $ nullDir >> showRSS cache lang, + notFound $ toResponse $ showError NotFound lang + ] staticHandler :: String -> ServerPart Response staticHandler resDir = do @@ -58,29 +63,29 @@ staticHandler resDir = do showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response showEntry cache lang eId = do - entry <- getEntry cache eId - tryEntry entry lang + entry <- getEntry cache eId + tryEntry entry lang tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry - where - eTitle = T.append ": " (title entry) - eLang = lang entry + where + eTitle = T.append ": " (title entry) + eLang = lang entry offset :: Maybe Int -> Int offset = maybe 0 ((*) pageSize) showIndex :: BlogCache -> BlogLang -> ServerPart Response showIndex cache lang = do - (page :: Maybe Int) <- optional $ lookRead "page" - entries <- listEntries cache (offset page) pageSize - ok $ toResponse $ blogTemplate lang "" $ - renderEntries entries (Just $ showLinks page lang) + (page :: Maybe Int) <- optional $ lookRead "page" + entries <- listEntries cache (offset page) pageSize + ok $ toResponse $ blogTemplate lang "" + $ renderEntries entries (Just $ showLinks page lang) showRSS :: BlogCache -> BlogLang -> ServerPart Response showRSS cache lang = do - entries <- listEntries cache 0 4 - feed <- liftIO $ renderFeed lang entries - setHeaderM "content-type" "text/xml" - ok $ toResponse feed + entries <- listEntries cache 0 4 + feed <- liftIO $ renderFeed lang entries + setHeaderM "content-type" "text/xml" + ok $ toResponse feed |