chore(blog): Minor changes to integrate DNS based backend

This commit is contained in:
Vincent Ambo 2019-08-22 18:58:11 +01:00
parent c5ef3e01b2
commit bd47122afb
5 changed files with 18 additions and 21 deletions

View file

@ -12,7 +12,6 @@
module Blog where module Blog where
import BlogStore import BlogStore
import Data.Maybe (fromJust)
import Data.Text (Text, empty, pack) import Data.Text (Text, empty, pack)
import Data.Text.Lazy (fromStrict) import Data.Text.Lazy (fromStrict)
import Data.Time import Data.Time
@ -26,12 +25,9 @@ import qualified Data.Text as T
replace :: Eq a => a -> a -> [a] -> [a] replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z) replace x y = map (\z -> if z == x then y else z)
show' :: Show a => a -> Text -- |After this date all entries are Markdown
show' = pack . show markdownCutoff :: Day
markdownCutoff = fromGregorian 2013 04 28
-- |After this time all entries are Markdown
markdownCutoff :: UTCTime
markdownCutoff = fromJust $ parseTimeM False defaultTimeLocale "%s" "1367149834"
-- blog HTML -- blog HTML
blogTemplate :: BlogLang -> Text -> Html -> Html blogTemplate :: BlogLang -> Text -> Html -> Html
@ -99,7 +95,7 @@ $maybe links <- pageLinks
where where
linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId] linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
showLinks :: Maybe Integer -> BlogLang -> Html showLinks :: Maybe Int -> BlogLang -> Html
showLinks (Just i) lang = [shamlet| showLinks (Just i) lang = [shamlet|
$if ((>) i 1) $if ((>) i 1)
<div .navigation> <div .navigation>

View file

@ -5,7 +5,7 @@ import qualified Data.Text as T
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Time (UTCTime, getCurrentTime) import Data.Time (UTCTime(..), getCurrentTime, secondsToDiffTime)
import Network.URI import Network.URI
import Text.RSS import Text.RSS
@ -13,11 +13,11 @@ import BlogStore
import Locales import Locales
createChannel :: BlogLang -> UTCTime -> [ChannelElem] createChannel :: BlogLang -> UTCTime -> [ChannelElem]
createChannel l now = [ Language $ show l createChannel l now = [ Language $ show l
, Copyright "Vincent Ambo" , Copyright "Vincent Ambo"
, WebMaster "tazjin@gmail.com" , WebMaster "tazjin@gmail.com"
, ChannelPubDate now , ChannelPubDate now
] ]
createRSS :: BlogLang -> UTCTime -> [Item] -> RSS createRSS :: BlogLang -> UTCTime -> [Item] -> RSS
createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t)
@ -26,7 +26,7 @@ createItem :: Entry -> Item
createItem Entry{..} = [ Title $ T.unpack title createItem Entry{..} = [ Title $ T.unpack title
, Link $ makeLink lang entryId , Link $ makeLink lang entryId
, Description $ T.unpack btext , Description $ T.unpack btext
, PubDate edate] , PubDate $ UTCTime edate $ secondsToDiffTime 0 ]
makeLink :: BlogLang -> EntryId -> URI makeLink :: BlogLang -> EntryId -> URI
makeLink l i = let url = "http://tazj.in/" ++ show l ++ "/" ++ show i makeLink l i = let url = "http://tazj.in/" ++ show l ++ "/" ++ show i

View file

@ -21,7 +21,7 @@ instance FromReqURI BlogLang where
"en" -> Just EN "en" -> Just EN
_ -> Nothing _ -> Nothing
pageSize :: Integer pageSize :: Int
pageSize = 3 pageSize = 3
tmpPolicy :: BodyPolicy tmpPolicy :: BodyPolicy
@ -68,12 +68,12 @@ tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEn
eTitle = T.append ": " (title entry) eTitle = T.append ": " (title entry)
eLang = lang entry eLang = lang entry
offset :: Maybe Integer -> Integer offset :: Maybe Int -> Int
offset = maybe 0 ((*) pageSize) offset = maybe 0 ((*) pageSize)
showIndex :: BlogCache -> BlogLang -> ServerPart Response showIndex :: BlogCache -> BlogLang -> ServerPart Response
showIndex cache lang = do showIndex cache lang = do
(page :: Maybe Integer) <- optional $ lookRead "page" (page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate lang "" $ ok $ toResponse $ blogTemplate lang "" $
renderEntries entries (Just $ showLinks page lang) renderEntries entries (Just $ showLinks page lang)

View file

@ -13,7 +13,8 @@ library
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -W ghc-options: -W
exposed-modules: Blog, BlogStore, Locales, Server, RSS exposed-modules: Blog, BlogStore, Locales, Server, RSS
build-depends: base, build-depends: aeson,
base,
bytestring, bytestring,
happstack-server, happstack-server,
text, text,

View file

@ -1,4 +1,4 @@
{ mkDerivation, acid-state, base, base64-bytestring, blaze-html { mkDerivation, aeson, acid-state, base, base64-bytestring, blaze-html
, blaze-markup, bytestring, cache, crypto-api, cryptohash, dns, hamlet , blaze-markup, bytestring, cache, crypto-api, cryptohash, dns, hamlet
, happstack-server, markdown, mtl, network, network-uri , happstack-server, markdown, mtl, network, network-uri
, old-locale, options, rss, shakespeare, stdenv, text , old-locale, options, rss, shakespeare, stdenv, text
@ -11,7 +11,7 @@ mkDerivation {
isLibrary = true; isLibrary = true;
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ libraryHaskellDepends = [
base base64-bytestring blaze-html blaze-markup bytestring aeson base base64-bytestring blaze-html blaze-markup bytestring
cache crypto-api cryptohash dns hamlet happstack-server markdown mtl cache crypto-api cryptohash dns hamlet happstack-server markdown mtl
network network-uri old-locale rss shakespeare text time network network-uri old-locale rss shakespeare text time
transformers transformers