about summary refs log tree commit diff
path: root/web/tazblog/src
diff options
context:
space:
mode:
Diffstat (limited to 'web/tazblog/src')
-rw-r--r--web/tazblog/src/Blog.hs141
-rw-r--r--web/tazblog/src/BlogStore.hs182
-rw-r--r--web/tazblog/src/RSS.hs48
-rw-r--r--web/tazblog/src/Server.hs81
4 files changed, 0 insertions, 452 deletions
diff --git a/web/tazblog/src/Blog.hs b/web/tazblog/src/Blog.hs
deleted file mode 100644
index 0a53b5f2fb..0000000000
--- a/web/tazblog/src/Blog.hs
+++ /dev/null
@@ -1,141 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Blog where
-
-import BlogStore
-import Data.Text (Text, pack)
-import qualified Data.Text as T
-import Data.Text.Lazy (fromStrict)
-import Data.Time
-import Text.Blaze.Html (preEscapedToHtml)
-import Text.Hamlet
-import Text.Markdown
-
-blogTitle :: Text = "tazjin's blog"
-
-repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
-
-mailTo :: Text = "mailto:mail@tazj.in"
-
-twitter :: Text = "https://twitter.com/tazjin"
-
-replace :: Eq a => a -> a -> [a] -> [a]
-replace x y = map (\z -> if z == x then y else z)
-
--- |After this date all entries are Markdown
-markdownCutoff :: Day
-markdownCutoff = fromGregorian 2013 04 28
-
-blogTemplate :: Text -> Html -> Html
-blogTemplate t_append body =
-  [shamlet|
-$doctype 5
-  <head>
-    <meta charset="utf-8">
-    <meta name="viewport" content="width=device-width, initial-scale=1">
-    <meta name="description" content=#{blogTitle}#{t_append}>
-    <link rel="stylesheet" type="text/css" href="/static/blog.css" media="all">
-    <link rel="alternate" type="application/rss+xml" title="RSS-Feed" href="/rss.xml">
-    <title>#{blogTitle}#{t_append}
-  <body>
-    <header>
-      <h1>
-        <a href="/" .unstyled-link>#{blogTitle}
-      <hr>
-    ^{body}
-    ^{showFooter}
-|]
-
-showFooter :: Html
-showFooter =
-  [shamlet|
-<footer>
-  <p .footer>Served without any dynamic languages.
-  <p .footer>
-    <a href=#{repoURL} .uncoloured-link>
-    |
-    <a href=#{twitter} .uncoloured-link>Twitter
-    |
-    <a href=#{mailTo} .uncoloured-link>Mail
-  <p .lod>
-    ಠ_ಠ
-|]
-
-isEntryMarkdown :: Entry -> Bool
-isEntryMarkdown e = edate e > markdownCutoff
-
-renderEntryMarkdown :: Text -> Html
-renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
-
-renderEntries :: [Entry] -> Maybe Html -> Html
-renderEntries entries pageLinks =
-  [shamlet|
-$forall entry <- entries
-  <article>
-    <h2 .inline>
-      <a href=#{linkElems entry} .unstyled-link>
-        #{title entry}
-    <aside .date>
-      #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" $ edate entry}
-    $if (isEntryMarkdown entry)
-      ^{renderEntryMarkdown $ text entry}
-    $else
-      ^{preEscapedToHtml $ text entry}
-  <hr>
-$maybe links <- pageLinks
-  ^{links}
-|]
-  where
-    linkElems Entry {..} = "/" ++ show entryId
-
-showLinks :: Maybe Int -> Html
-showLinks (Just i) =
-  [shamlet|
-  $if ((>) i 1)
-    <div .navigation>
-      <a href=#{nLink $ succ i} .uncoloured-link>Earlier
-      |
-      <a href=#{nLink $ pred i} .uncoloured-link>Later
-  $elseif ((<=) i 1)
-    ^{showLinks Nothing}
-|]
-  where
-    nLink page = T.concat ["/?page=", show' page]
-showLinks Nothing =
-  [shamlet|
-<div .navigation>
-  <a href="/?page=2" .uncoloured-link>Earlier
-|]
-
-renderEntry :: Entry -> Html
-renderEntry e@Entry {..} =
-  [shamlet|
-<article>
-  <h2 .inline>
-    #{title}
-  <aside .date>
-    #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" edate}
-  $if (isEntryMarkdown e)
-    ^{renderEntryMarkdown text}
-  $else
-    ^{preEscapedToHtml $ text}
-<hr>
-|]
-
-showError :: Text -> Text -> Html
-showError title err =
-  blogTemplate (": " <> title)
-    [shamlet|
-<p>:(
-<p>#{err}
-<hr>
-|]
diff --git a/web/tazblog/src/BlogStore.hs b/web/tazblog/src/BlogStore.hs
deleted file mode 100644
index 60ccd0b5a0..0000000000
--- a/web/tazblog/src/BlogStore.hs
+++ /dev/null
@@ -1,182 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- |This module implements fetching of individual blog entries from
--- DNS. Yes, you read that correctly.
---
--- Each blog post is stored as a set of records in a designated DNS
--- zone. For the production blog, this zone is `blog.tazj.in.`.
---
--- A top-level record at `_posts` contains a list of all published
--- post IDs.
---
--- For each of these post IDs, there is a record at `_meta.$postID`
--- that contains the title and number of post chunks.
---
--- For each post chunk, there is a record at `_$chunkID.$postID` that
--- contains a base64-encoded post fragment.
---
--- This module implements logic for assembling a post out of these
--- fragments and caching it based on the TTL of its `_meta` record.
-module BlogStore
-  ( BlogCache,
-    EntryId (..),
-    Entry (..),
-    withCache,
-    listEntries,
-    getEntry,
-    show'
-    )
-where
-
-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 (decodeUtf8', encodeUtf8)
-import Data.Time (Day)
-import Network.DNS (DNSError, lookupTXT)
-import qualified Network.DNS.Resolver as R
-
-newtype EntryId = EntryId {unEntryId :: Integer}
-  deriving (Eq, Ord, FromJSON)
-
-instance Show EntryId where
-
-  show = show . unEntryId
-
-data Entry
-  = Entry
-      { entryId :: EntryId,
-        author :: Text,
-        title :: Text,
-        text :: Text,
-        edate :: Day
-        }
-  deriving (Eq, Ord, Show)
-
--- | Wraps a DNS resolver with caching configured. For the initial
--- version of this, all caching of entries is done by the resolver
--- (i.e. no pre-assembled versions of entries are cached).
-data BlogCache = BlogCache R.Resolver Text
-
-data StoreError
-  = PostNotFound EntryId
-  | DNS DNSError
-  | InvalidMetadata
-  | InvalidChunk
-  | InvalidPosts
-  deriving (Show)
-
-type Offset = Int
-
-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
-            }
-  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
-
-getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
-getEntry cache eid = liftIO $ entryFromDNS cache eid >>= \case
-  Left _ -> return Nothing -- TODO: ??
-  Right entry -> return $ Just entry
-
-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.
-data Meta = Meta Integer Text Day
-  deriving (Show)
-
-instance FromJSON Meta where
-
-  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
-        Nothing -> 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 =
-  let domain = encodeUtf8 ("_" <> show' c <> "." <> show' eid <> "." <> z)
-      record = lookupTXT r domain
-      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
-
-fetchAssembleChunks :: BlogCache -> EntryId -> Meta -> IO (Either StoreError Text)
-fetchAssembleChunks cache eid (Meta n _ _) = do
-  chunks <- mapM (entryChunk cache eid) [0 .. (n - 1)]
-  return $ fmap T.concat $ sequence chunks
-
-entryFromDNS :: BlogCache -> EntryId -> IO (Either StoreError Entry)
-entryFromDNS cache eid = do
-  meta <- entryMetadata cache eid
-  case meta of
-    Left err -> return $ Left err
-    Right meta -> do
-      chunks <- fetchAssembleChunks cache eid meta
-      let (Meta _ t d) = meta
-      return
-        $ either Left
-            ( \text -> Right $ Entry
-                { entryId = eid,
-                  author = "tazjin",
-                  title = t,
-                  text = text,
-                  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))
-          . mapM (maybe (Left InvalidPosts) Right . decodeStrict)
-   in either (Left . DNS) toPosts <$> record
diff --git a/web/tazblog/src/RSS.hs b/web/tazblog/src/RSS.hs
deleted file mode 100644
index 913aa9a408..0000000000
--- a/web/tazblog/src/RSS.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-module RSS
-  ( renderFeed
-    )
-where
-
-import BlogStore
-import Data.Maybe (fromJust)
-import qualified Data.Text as T
-import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime)
-import Network.URI (URI, parseURI)
-import Text.RSS
-
-createChannel :: UTCTime -> [ChannelElem]
-createChannel now =
-  [ Language "en",
-    Copyright "Vincent Ambo",
-    WebMaster "mail@tazj.in",
-    ChannelPubDate now
-    ]
-
-createRSS :: UTCTime -> [Item] -> RSS
-createRSS t =
-  let link = fromJust $ parseURI "https://tazj.in"
-   in RSS "tazjin's blog" link "tazjin's blog feed" (createChannel t)
-
-createItem :: Entry -> Item
-createItem Entry {..} =
-  [ Title "tazjin's blog",
-    Link $ entryLink entryId,
-    Description $ T.unpack text,
-    PubDate $ UTCTime edate $ secondsToDiffTime 0
-    ]
-
-entryLink :: EntryId -> URI
-entryLink i =
-  let url = "http://tazj.in/" ++ "/" ++ show i
-   in fromJust $ parseURI url
-
-createItems :: [Entry] -> [Item]
-createItems = map createItem
-
-createFeed :: [Entry] -> IO RSS
-createFeed e = getCurrentTime >>= (\t -> return $ createRSS t $ createItems e)
-
-renderFeed :: [Entry] -> IO String
-renderFeed e = fmap (showXML . rssToXML) (createFeed e)
diff --git a/web/tazblog/src/Server.hs b/web/tazblog/src/Server.hs
deleted file mode 100644
index 4012998839..0000000000
--- a/web/tazblog/src/Server.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Server where
-
-import Blog
-import BlogStore
-import Control.Applicative (optional)
-import Control.Monad (msum)
-import Control.Monad.IO.Class (liftIO)
-import Data.Maybe (maybe)
-import qualified Data.Text as T
-import Happstack.Server hiding (Session)
-import RSS
-
-pageSize :: Int
-pageSize = 3
-
-tmpPolicy :: BodyPolicy
-tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
-
-runBlog :: Int -> String -> IO ()
-runBlog port respath =
-  withCache "blog.tazj.in." $ \cache ->
-    simpleHTTP nullConf {port = port} $ tazblog cache respath
-
-tazblog :: BlogCache -> String -> ServerPart Response
-tazblog cache resDir =
-  msum
-    [ -- legacy language-specific routes
-      dir "de" $ blogHandler cache,
-      dir "en" $ blogHandler cache,
-      dir "static" $ staticHandler resDir,
-      blogHandler cache,
-      staticHandler resDir,
-      notFound $ toResponse $ showError "Not found" "Page not found"
-      ]
-
-blogHandler :: BlogCache -> ServerPart Response
-blogHandler cache =
-  msum
-    [ path $ \(eId :: Integer) -> showEntry cache $ EntryId eId,
-      nullDir >> showIndex cache,
-      dir "rss" $ nullDir >> showRSS cache,
-      dir "rss.xml" $ nullDir >> showRSS cache
-      ]
-
-staticHandler :: String -> ServerPart Response
-staticHandler resDir = do
-  setHeaderM "cache-control" "max-age=630720000"
-  setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
-  serveDirectory DisableBrowsing [] resDir
-
-showEntry :: BlogCache -> EntryId -> ServerPart Response
-showEntry cache eId = do
-  entry <- getEntry cache eId
-  tryEntry entry
-
-tryEntry :: Maybe Entry -> ServerPart Response
-tryEntry Nothing = notFound $ toResponse $ showError "Not found" "Blog entry not found"
-tryEntry (Just entry) = ok $ toResponse $ blogTemplate eTitle $ renderEntry entry
-  where
-    eTitle = T.append ": " (title entry)
-
-offset :: Maybe Int -> Int
-offset = maybe 0 (pageSize *)
-
-showIndex :: BlogCache -> ServerPart Response
-showIndex cache = do
-  (page :: Maybe Int) <- optional $ lookRead "page"
-  entries <- listEntries cache (offset page) pageSize
-  ok $ toResponse $ blogTemplate ""
-    $ renderEntries entries (Just $ showLinks page)
-
-showRSS :: BlogCache -> ServerPart Response
-showRSS cache = do
-  entries <- listEntries cache 0 4
-  feed <- liftIO $ renderFeed entries
-  setHeaderM "content-type" "text/xml"
-  ok $ toResponse feed
generated by cgit-pink 1.4.1 (git 2.44.0) at 2024-05-10T14·02+0000