chore(tazblog): Replace BlogDB with stubs for DNS-based storage
Removes acid-state specific code and the former BlogDB module, in its stead the new BlogStorage module contains stubs for the functions that will be filled in with DNS-based storage. This code is unformatted and will not currently serve a working blog.
This commit is contained in:
Vincent Ambo
parent
1d5b53abf8
commit
11fcf62297
10 changed files with 116 additions and 561 deletions
|
|
@ -1,11 +1,8 @@
|
||||||
-- | Main module for the blog's web server
|
-- | Main module for the blog's web server
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import BlogDB (initialBlogState)
|
import Control.Applicative (pure, (<*>))
|
||||||
import Control.Applicative (pure, (<$>), (<*>))
|
|
||||||
import Control.Exception (bracket)
|
import Control.Exception (bracket)
|
||||||
import Data.Acid
|
|
||||||
import Data.Acid.Remote
|
|
||||||
import Data.Word (Word16)
|
import Data.Word (Word16)
|
||||||
import Locales (version)
|
import Locales (version)
|
||||||
import Network (HostName, PortID (..))
|
import Network (HostName, PortID (..))
|
||||||
|
|
@ -13,18 +10,12 @@ import Options
|
||||||
import Server
|
import Server
|
||||||
|
|
||||||
data MainOptions = MainOptions {
|
data MainOptions = MainOptions {
|
||||||
dbHost :: String,
|
|
||||||
dbPort :: Word16,
|
|
||||||
blogPort :: Int,
|
blogPort :: Int,
|
||||||
resourceDir :: String
|
resourceDir :: String
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Options MainOptions where
|
instance Options MainOptions where
|
||||||
defineOptions = pure MainOptions
|
defineOptions = pure MainOptions
|
||||||
<*> simpleOption "dbHost" "localhost"
|
|
||||||
"Remote acid-state database host. Default is localhost"
|
|
||||||
<*> simpleOption "dbPort" 8070
|
|
||||||
"Remote acid-state database port. Default is 8070"
|
|
||||||
<*> simpleOption "blogPort" 8000
|
<*> simpleOption "blogPort" 8000
|
||||||
"Port to serve the blog on. Default is 8000."
|
"Port to serve the blog on. Default is 8000."
|
||||||
<*> simpleOption "resourceDir" "/opt/tazblog/static"
|
<*> simpleOption "resourceDir" "/opt/tazblog/static"
|
||||||
|
|
@ -34,8 +25,4 @@ main :: IO()
|
||||||
main = do
|
main = do
|
||||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||||
runCommand $ \opts _ ->
|
runCommand $ \opts _ ->
|
||||||
let port = PortNumber $ fromIntegral $ dbPort opts
|
runBlog (blogPort opts) (resourceDir opts)
|
||||||
in openRemoteState skipAuthenticationPerform (dbHost opts) port >>=
|
|
||||||
(\acid -> runBlog acid (blogPort opts) (resourceDir opts))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,34 +0,0 @@
|
||||||
-- | Main module for the database server
|
|
||||||
module Main where
|
|
||||||
|
|
||||||
import BlogDB (initialBlogState)
|
|
||||||
import Control.Applicative (pure, (<$>), (<*>))
|
|
||||||
import Control.Exception (bracket)
|
|
||||||
import Data.Acid
|
|
||||||
import Data.Acid.Local (createCheckpointAndClose)
|
|
||||||
import Data.Acid.Remote
|
|
||||||
import Data.Word
|
|
||||||
import Network (PortID (..))
|
|
||||||
import Options
|
|
||||||
|
|
||||||
data DBOptions = DBOptions {
|
|
||||||
dbPort :: Word16,
|
|
||||||
stateDirectory :: String
|
|
||||||
}
|
|
||||||
|
|
||||||
instance Options DBOptions where
|
|
||||||
defineOptions = pure DBOptions
|
|
||||||
<*> simpleOption "dbport" 8070
|
|
||||||
"Port to serve acid-state on remotely."
|
|
||||||
<*> simpleOption "state" "/var/tazblog/state"
|
|
||||||
"Directory in which the acid-state is located."
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
putStrLn ("Launching TazBlog database server ...")
|
|
||||||
runCommand $ \opts args ->
|
|
||||||
bracket (openState opts) createCheckpointAndClose
|
|
||||||
(acidServer skipAuthenticationCheck $ getPort opts)
|
|
||||||
where
|
|
||||||
openState o = openLocalStateFrom (stateDirectory o) initialBlogState
|
|
||||||
getPort = PortNumber . fromIntegral . dbPort
|
|
||||||
|
|
@ -11,9 +11,9 @@
|
||||||
|
|
||||||
module Blog where
|
module Blog where
|
||||||
|
|
||||||
import BlogDB
|
import BlogStore
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Data.Text (Text, append, empty, pack)
|
import Data.Text (Text, empty, pack)
|
||||||
import Data.Text.Lazy (fromStrict)
|
import Data.Text.Lazy (fromStrict)
|
||||||
import Data.Time
|
import Data.Time
|
||||||
import Locales
|
import Locales
|
||||||
|
|
@ -75,9 +75,9 @@ isEntryMarkdown e = edate e > markdownCutoff
|
||||||
renderEntryMarkdown :: Text -> Html
|
renderEntryMarkdown :: Text -> Html
|
||||||
renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
|
renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
|
||||||
|
|
||||||
renderEntries :: Bool -> [Entry] -> Maybe Html -> Html
|
renderEntries :: [Entry] -> Maybe Html -> Html
|
||||||
renderEntries showAll entries pageLinks = [shamlet|
|
renderEntries entries pageLinks = [shamlet|
|
||||||
$forall entry <- toDisplay
|
$forall entry <- entries
|
||||||
<article>
|
<article>
|
||||||
<h2 .inline>
|
<h2 .inline>
|
||||||
<a href=#{linkElems entry} .unstyled-link>
|
<a href=#{linkElems entry} .unstyled-link>
|
||||||
|
|
@ -97,10 +97,9 @@ $maybe links <- pageLinks
|
||||||
^{links}
|
^{links}
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
toDisplay = if showAll then entries else (take 6 entries)
|
|
||||||
linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
|
linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
|
||||||
|
|
||||||
showLinks :: Maybe Int -> BlogLang -> Html
|
showLinks :: Maybe Integer -> BlogLang -> Html
|
||||||
showLinks (Just i) lang = [shamlet|
|
showLinks (Just i) lang = [shamlet|
|
||||||
$if ((>) i 1)
|
$if ((>) i 1)
|
||||||
<div .navigation>
|
<div .navigation>
|
||||||
|
|
@ -135,103 +134,6 @@ renderEntry e@Entry{..} = [shamlet|
|
||||||
<hr>
|
<hr>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
{- Administration pages -}
|
|
||||||
|
|
||||||
adminTemplate :: Text -> Html -> Html
|
|
||||||
adminTemplate title body = [shamlet|
|
|
||||||
$doctype 5
|
|
||||||
<head>
|
|
||||||
<link rel="stylesheet" type="text/css" href="/static/admin.css" media="all">
|
|
||||||
<meta http-equiv="content-type" content="text/html;charset=UTF-8">
|
|
||||||
<title>#{append "TazBlog Admin: " title}
|
|
||||||
<body>
|
|
||||||
^{body}
|
|
||||||
|]
|
|
||||||
|
|
||||||
adminLogin :: Html
|
|
||||||
adminLogin = adminTemplate "Login" $ [shamlet|
|
|
||||||
<div class="loginBox">
|
|
||||||
<div class="loginBoxTop">TazBlog Admin: Login
|
|
||||||
<div class="loginBoxMiddle">
|
|
||||||
<form action="/admin" method="POST">
|
|
||||||
<p>Account ID
|
|
||||||
<p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1">
|
|
||||||
<p>Passwort
|
|
||||||
<p><input type="password" style="font-size:2;" name="password">
|
|
||||||
<p><input alt="Anmelden" type="image" src="/static/signin.gif">
|
|
||||||
|]
|
|
||||||
|
|
||||||
adminIndex :: Text -> Html
|
|
||||||
adminIndex sUser = adminTemplate "Index" $ [shamlet|
|
|
||||||
<div style="float:center;">
|
|
||||||
<form action="/admin/entry" method="POST">
|
|
||||||
<table>
|
|
||||||
<tr>
|
|
||||||
<thead><td>Title:
|
|
||||||
<td><input type="text" name="title">
|
|
||||||
<tr>
|
|
||||||
<thead><td>Language:
|
|
||||||
<td><select name="lang">
|
|
||||||
<option value="en">English
|
|
||||||
<option value="de">Deutsch
|
|
||||||
<tr>
|
|
||||||
<thead><td>Text:
|
|
||||||
<td>
|
|
||||||
<textarea name="btext" cols="100" rows="15">
|
|
||||||
<tr>
|
|
||||||
<thead>
|
|
||||||
<td style="vertical-align:top;">Read more:
|
|
||||||
<td>
|
|
||||||
<textarea name="mtext" cols="100" rows="15">
|
|
||||||
<input type="hidden" name="author" value=#{sUser}>
|
|
||||||
<input style="margin-left:20px;" type="submit" value="Submit">
|
|
||||||
^{adminFooter}
|
|
||||||
|]
|
|
||||||
|
|
||||||
adminFooter :: Html
|
|
||||||
adminFooter = [shamlet|
|
|
||||||
<a href="/">Front page
|
|
||||||
\ -- #
|
|
||||||
<a href="/admin">New article
|
|
||||||
\ -- Entry list: #
|
|
||||||
<a href="/admin/entrylist/en">EN
|
|
||||||
\ & #
|
|
||||||
<a href="/admin/entrylist/de">DE
|
|
||||||
|]
|
|
||||||
|
|
||||||
adminEntryList :: [Entry] -> Html
|
|
||||||
adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
|
|
||||||
<div style="float: center;">
|
|
||||||
<table>
|
|
||||||
$forall entry <- entries
|
|
||||||
<tr>
|
|
||||||
<td><a href=#{append "/admin/entry/" (show' $ entryId entry)}>#{title entry}
|
|
||||||
<td>#{formatPostDate $ edate entry}
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
formatPostDate = formatTime defaultTimeLocale "[On %D at %H:%M]"
|
|
||||||
|
|
||||||
editPage :: Entry -> Html
|
|
||||||
editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
|
|
||||||
<div style="float:center;">
|
|
||||||
<form action=#{append "/admin/entry/" (show' entryId)} method="POST">
|
|
||||||
<table>
|
|
||||||
<tr>
|
|
||||||
<td>Title:
|
|
||||||
<td>
|
|
||||||
<input type="text" name="title" value=#{title}>
|
|
||||||
<tr>
|
|
||||||
<td style="vertical-align:top;">Text:
|
|
||||||
<td>
|
|
||||||
<textarea name="btext" cols="100" rows="15">#{btext}
|
|
||||||
<tr>
|
|
||||||
<td style="vertical-align:top;">Read more:
|
|
||||||
<td>
|
|
||||||
<textarea name="mtext" cols="100" rows="15">#{mtext}
|
|
||||||
<input type="submit" style="margin-left:20px;" value="Submit">
|
|
||||||
<p>^{adminFooter}
|
|
||||||
|]
|
|
||||||
|
|
||||||
showError :: BlogError -> BlogLang -> Html
|
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>:(
|
||||||
|
|
|
||||||
|
|
@ -1,241 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module BlogDB where
|
|
||||||
|
|
||||||
import Control.Monad.Reader (ask)
|
|
||||||
import Control.Monad.State (get, put)
|
|
||||||
import Data.Acid
|
|
||||||
import Data.Acid.Advanced
|
|
||||||
import Data.Acid.Remote
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Data (Data, Typeable)
|
|
||||||
import Data.IxSet (Indexable (..), IxSet, Proxy (..),
|
|
||||||
getOne, ixFun, ixSet, (@=))
|
|
||||||
import Data.SafeCopy (base, deriveSafeCopy)
|
|
||||||
import Data.Text (Text, pack)
|
|
||||||
import Data.Time
|
|
||||||
import Network (PortID (..))
|
|
||||||
import System.Environment (getEnv)
|
|
||||||
|
|
||||||
import qualified Crypto.Hash.SHA512 as SHA (hash)
|
|
||||||
import qualified Data.ByteString.Base64 as B64 (encode)
|
|
||||||
import qualified Data.ByteString.Char8 as B
|
|
||||||
import qualified Data.IxSet as IxSet
|
|
||||||
|
|
||||||
newtype EntryId = EntryId { unEntryId :: Integer }
|
|
||||||
deriving (Eq, Ord, Data, Enum, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 2 'base ''EntryId)
|
|
||||||
|
|
||||||
instance Show EntryId where
|
|
||||||
show = show . unEntryId
|
|
||||||
|
|
||||||
data BlogLang = EN | DE
|
|
||||||
deriving (Eq, Ord, Data, Typeable)
|
|
||||||
|
|
||||||
instance Show BlogLang where
|
|
||||||
show DE = "de"
|
|
||||||
show EN = "en"
|
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''BlogLang)
|
|
||||||
|
|
||||||
data Entry = Entry {
|
|
||||||
entryId :: EntryId,
|
|
||||||
lang :: BlogLang,
|
|
||||||
author :: Text,
|
|
||||||
title :: Text,
|
|
||||||
btext :: Text,
|
|
||||||
mtext :: Text,
|
|
||||||
edate :: UTCTime
|
|
||||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 2 'base ''Entry)
|
|
||||||
|
|
||||||
-- ixSet requires different datatypes for field indexes, so let's define some
|
|
||||||
newtype Author = Author Text deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype Title = Title Text deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype BText = BText Text deriving (Eq, Ord, Data, Typeable) -- standard text
|
|
||||||
newtype MText = MText Text deriving (Eq, Ord, Data, Typeable) -- "read more" text
|
|
||||||
newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype EDate = EDate UTCTime deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype Username = Username Text deriving (Eq, Ord, Data, Typeable)
|
|
||||||
newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 2 'base ''Author)
|
|
||||||
$(deriveSafeCopy 2 'base ''Title)
|
|
||||||
$(deriveSafeCopy 2 'base ''BText)
|
|
||||||
$(deriveSafeCopy 2 'base ''MText)
|
|
||||||
$(deriveSafeCopy 2 'base ''Tag)
|
|
||||||
$(deriveSafeCopy 2 'base ''EDate)
|
|
||||||
$(deriveSafeCopy 2 'base ''SDate)
|
|
||||||
$(deriveSafeCopy 2 'base ''Username)
|
|
||||||
$(deriveSafeCopy 2 'base ''SessionID)
|
|
||||||
|
|
||||||
instance Indexable Entry where
|
|
||||||
empty = ixSet [ ixFun $ \e -> [ entryId e]
|
|
||||||
, ixFun $ (:[]) . lang
|
|
||||||
, ixFun $ \e -> [ Author $ author e ]
|
|
||||||
, ixFun $ \e -> [ Title $ title e]
|
|
||||||
, ixFun $ \e -> [ BText $ btext e]
|
|
||||||
, ixFun $ \e -> [ MText $ mtext e]
|
|
||||||
, ixFun $ \e -> [ EDate $ edate e]
|
|
||||||
]
|
|
||||||
|
|
||||||
data User = User {
|
|
||||||
username :: Text,
|
|
||||||
password :: ByteString
|
|
||||||
} deriving (Eq, Ord, Data, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''User)
|
|
||||||
|
|
||||||
data Session = Session {
|
|
||||||
sessionID :: Text,
|
|
||||||
user :: User,
|
|
||||||
sdate :: UTCTime
|
|
||||||
} deriving (Eq, Ord, Data, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''Session)
|
|
||||||
|
|
||||||
instance Indexable User where
|
|
||||||
empty = ixSet [ ixFun $ \u -> [Username $ username u]
|
|
||||||
, ixFun $ (:[]) . password
|
|
||||||
]
|
|
||||||
|
|
||||||
instance Indexable Session where
|
|
||||||
empty = ixSet [ ixFun $ \s -> [SessionID $ sessionID s]
|
|
||||||
, ixFun $ (:[]) . user
|
|
||||||
, ixFun $ \s -> [SDate $ sdate s]
|
|
||||||
]
|
|
||||||
|
|
||||||
data Blog = Blog {
|
|
||||||
blogSessions :: IxSet Session,
|
|
||||||
blogUsers :: IxSet User,
|
|
||||||
blogEntries :: IxSet Entry
|
|
||||||
} deriving (Data, Typeable)
|
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''Blog)
|
|
||||||
|
|
||||||
initialBlogState :: Blog
|
|
||||||
initialBlogState =
|
|
||||||
Blog { blogSessions = empty
|
|
||||||
, blogUsers = empty
|
|
||||||
, blogEntries = empty }
|
|
||||||
|
|
||||||
-- acid-state database functions (purity is necessary!)
|
|
||||||
|
|
||||||
insertEntry :: Entry -> Update Blog Entry
|
|
||||||
insertEntry e =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
put $ b { blogEntries = IxSet.insert e blogEntries }
|
|
||||||
return e
|
|
||||||
|
|
||||||
updateEntry :: Entry -> Update Blog Entry
|
|
||||||
updateEntry e =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries }
|
|
||||||
return e
|
|
||||||
|
|
||||||
deleteEntry :: EntryId -> Update Blog EntryId
|
|
||||||
deleteEntry entry =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
put $ b { blogEntries = IxSet.deleteIx entry blogEntries }
|
|
||||||
return entry
|
|
||||||
|
|
||||||
getEntry :: EntryId -> Query Blog (Maybe Entry)
|
|
||||||
getEntry eId =
|
|
||||||
do Blog{..} <- ask
|
|
||||||
return $ getOne $ blogEntries @= eId
|
|
||||||
|
|
||||||
latestEntries :: BlogLang -> Query Blog [Entry]
|
|
||||||
latestEntries lang =
|
|
||||||
do Blog{..} <- ask
|
|
||||||
return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang
|
|
||||||
|
|
||||||
addSession :: Session -> Update Blog Session
|
|
||||||
addSession nSession =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
put $ b { blogSessions = IxSet.insert nSession blogSessions}
|
|
||||||
return nSession
|
|
||||||
|
|
||||||
getSession :: SessionID -> Query Blog (Maybe Session)
|
|
||||||
getSession sId =
|
|
||||||
do Blog{..} <- ask
|
|
||||||
return $ getOne $ blogSessions @= sId
|
|
||||||
|
|
||||||
clearSessions :: Update Blog [Session]
|
|
||||||
clearSessions =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
put $ b { blogSessions = empty }
|
|
||||||
return []
|
|
||||||
|
|
||||||
addUser :: Text -> String -> Update Blog User
|
|
||||||
addUser un pw =
|
|
||||||
do b@Blog{..} <- get
|
|
||||||
let u = User un $ hashString pw
|
|
||||||
put $ b { blogUsers = IxSet.insert u blogUsers}
|
|
||||||
return u
|
|
||||||
|
|
||||||
getUser :: Username -> Query Blog (Maybe User)
|
|
||||||
getUser uN =
|
|
||||||
do Blog{..} <- ask
|
|
||||||
return $ getOne $ blogUsers @= uN
|
|
||||||
|
|
||||||
checkUser :: Username -> String -> Query Blog Bool
|
|
||||||
checkUser uN pw =
|
|
||||||
do Blog{..} <- ask
|
|
||||||
let user = getOne $ blogUsers @= uN
|
|
||||||
case user of
|
|
||||||
Nothing -> return False
|
|
||||||
(Just u) -> return $ password u == hashString pw
|
|
||||||
|
|
||||||
-- various functions
|
|
||||||
hashString :: String -> ByteString
|
|
||||||
hashString = B64.encode . SHA.hash . B.pack
|
|
||||||
|
|
||||||
$(makeAcidic ''Blog
|
|
||||||
[ 'insertEntry
|
|
||||||
, 'updateEntry
|
|
||||||
, 'deleteEntry
|
|
||||||
, 'getEntry
|
|
||||||
, 'latestEntries
|
|
||||||
, 'addSession
|
|
||||||
, 'getSession
|
|
||||||
, 'addUser
|
|
||||||
, 'getUser
|
|
||||||
, 'checkUser
|
|
||||||
, 'clearSessions
|
|
||||||
])
|
|
||||||
|
|
||||||
interactiveUserAdd :: String -> IO ()
|
|
||||||
interactiveUserAdd dbHost = do
|
|
||||||
acid <- openRemoteState skipAuthenticationPerform dbHost (PortNumber 8070)
|
|
||||||
putStrLn "Username:"
|
|
||||||
un <- getLine
|
|
||||||
putStrLn "Password:"
|
|
||||||
pw <- getLine
|
|
||||||
update' acid (AddUser (pack un) pw)
|
|
||||||
closeAcidState acid
|
|
||||||
|
|
||||||
flushSessions :: IO ()
|
|
||||||
flushSessions = do
|
|
||||||
tbDir <- getEnv "TAZBLOG"
|
|
||||||
acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
|
|
||||||
update' acid ClearSessions
|
|
||||||
closeAcidState acid
|
|
||||||
|
|
||||||
archiveState :: IO ()
|
|
||||||
archiveState = do
|
|
||||||
tbDir <- getEnv "TAZBLOG"
|
|
||||||
acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
|
|
||||||
createArchive acid
|
|
||||||
closeAcidState acid
|
|
||||||
54
services/tazblog/src/BlogStore.hs
Normal file
54
services/tazblog/src/BlogStore.hs
Normal file
|
|
@ -0,0 +1,54 @@
|
||||||
|
-- |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 where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Locales (BlogLang(..))
|
||||||
|
import Data.Time (UTCTime)
|
||||||
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
|
|
||||||
|
newtype EntryId = EntryId { unEntryId :: Integer }
|
||||||
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
|
instance Show EntryId where
|
||||||
|
show = show . unEntryId
|
||||||
|
|
||||||
|
data Entry = Entry {
|
||||||
|
entryId :: EntryId,
|
||||||
|
lang :: BlogLang,
|
||||||
|
author :: Text,
|
||||||
|
title :: Text,
|
||||||
|
btext :: Text,
|
||||||
|
mtext :: Text,
|
||||||
|
edate :: UTCTime
|
||||||
|
} deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
data BlogCache
|
||||||
|
|
||||||
|
type Offset = Integer
|
||||||
|
type Count = Integer
|
||||||
|
|
||||||
|
newCache :: String -> IO BlogCache
|
||||||
|
newCache zone = undefined
|
||||||
|
|
||||||
|
listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
|
||||||
|
listEntries cache offset count = undefined
|
||||||
|
|
||||||
|
getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
|
||||||
|
getEntry cache eId = undefined
|
||||||
|
|
@ -1,15 +1,21 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
|
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
|
||||||
module Locales where
|
module Locales where
|
||||||
|
|
||||||
import BlogDB (BlogLang (..))
|
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Network.URI
|
import Network.URI
|
||||||
|
|
||||||
|
data BlogLang = EN | DE
|
||||||
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
|
instance Show BlogLang where
|
||||||
|
show DE = "de"
|
||||||
|
show EN = "en"
|
||||||
|
|
||||||
data BlogError = NotFound | UnknownError
|
data BlogError = NotFound | UnknownError
|
||||||
|
|
||||||
version = "5.1.2"
|
version = "6.0.0"
|
||||||
|
|
||||||
blogTitle :: BlogLang -> Text -> Text
|
blogTitle :: BlogLang -> Text -> Text
|
||||||
blogTitle DE s = T.concat ["Tazjins blog", s]
|
blogTitle DE s = T.concat ["Tazjins blog", s]
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ import Data.Time (UTCTime, getCurrentTime)
|
||||||
import Network.URI
|
import Network.URI
|
||||||
import Text.RSS
|
import Text.RSS
|
||||||
|
|
||||||
import BlogDB hiding (Title)
|
import BlogStore
|
||||||
import Locales
|
import Locales
|
||||||
|
|
||||||
createChannel :: BlogLang -> UTCTime -> [ChannelElem]
|
createChannel :: BlogLang -> UTCTime -> [ChannelElem]
|
||||||
|
|
|
||||||
|
|
@ -2,20 +2,15 @@
|
||||||
module Server where
|
module Server where
|
||||||
|
|
||||||
import Control.Applicative (optional)
|
import Control.Applicative (optional)
|
||||||
import Control.Monad (msum, mzero, unless)
|
import Control.Monad (msum)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Data.Acid
|
|
||||||
import Data.Acid.Advanced
|
|
||||||
import Data.ByteString.Char8 (unpack)
|
|
||||||
import Data.Char (toLower)
|
import Data.Char (toLower)
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time
|
|
||||||
import Happstack.Server hiding (Session)
|
import Happstack.Server hiding (Session)
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (maybe)
|
||||||
|
|
||||||
import Blog
|
import Blog
|
||||||
import BlogDB hiding (updateEntry)
|
import BlogStore
|
||||||
import Locales
|
import Locales
|
||||||
import RSS
|
import RSS
|
||||||
|
|
||||||
|
|
@ -26,32 +21,32 @@ instance FromReqURI BlogLang where
|
||||||
"en" -> Just EN
|
"en" -> Just EN
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
pageSize :: Integer
|
||||||
|
pageSize = 3
|
||||||
|
|
||||||
tmpPolicy :: BodyPolicy
|
tmpPolicy :: BodyPolicy
|
||||||
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
|
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
|
||||||
|
|
||||||
runBlog :: AcidState Blog -> Int -> String -> IO ()
|
runBlog :: Int -> String -> IO ()
|
||||||
runBlog acid port respath =
|
runBlog port respath = do
|
||||||
simpleHTTP nullConf {port = port} $ tazBlog acid respath
|
cache <- newCache "blog.tazj.in."
|
||||||
|
simpleHTTP nullConf {port = port} $ tazBlog cache respath
|
||||||
|
|
||||||
tazBlog :: AcidState Blog -> String -> ServerPart Response
|
tazBlog :: BlogCache -> String -> ServerPart Response
|
||||||
tazBlog acid resDir = do
|
tazBlog cache resDir = do
|
||||||
msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
|
msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang
|
||||||
, dir "admin" $ msum [
|
|
||||||
adminHandler acid -- this checks auth
|
|
||||||
, method GET >> (ok $ toResponse adminLogin)
|
|
||||||
, method POST >> processLogin acid ]
|
|
||||||
, dir "static" $ staticHandler resDir
|
, dir "static" $ staticHandler resDir
|
||||||
, blogHandler acid EN
|
, blogHandler cache EN
|
||||||
, staticHandler resDir
|
, staticHandler resDir
|
||||||
, notFound $ toResponse $ showError NotFound DE
|
, notFound $ toResponse $ showError NotFound DE
|
||||||
]
|
]
|
||||||
|
|
||||||
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
blogHandler :: BlogCache -> BlogLang -> ServerPart Response
|
||||||
blogHandler acid lang =
|
blogHandler cache lang =
|
||||||
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
msum [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId
|
||||||
, nullDir >> showIndex acid lang
|
, nullDir >> showIndex cache lang
|
||||||
, dir "rss" $ nullDir >> showRSS acid lang
|
, dir "rss" $ nullDir >> showRSS cache lang
|
||||||
, dir "rss.xml" $ nullDir >> showRSS acid lang
|
, dir "rss.xml" $ nullDir >> showRSS cache lang
|
||||||
, notFound $ toResponse $ showError NotFound lang
|
, notFound $ toResponse $ showError NotFound lang
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
@ -61,20 +56,9 @@ staticHandler resDir = do
|
||||||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||||
serveDirectory DisableBrowsing [] resDir
|
serveDirectory DisableBrowsing [] resDir
|
||||||
|
|
||||||
adminHandler :: AcidState Blog -> ServerPart Response
|
showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
|
||||||
adminHandler acid = do
|
showEntry cache lang eId = do
|
||||||
guardSession acid
|
entry <- getEntry cache eId
|
||||||
msum [ dir "entry" $ method POST >> postEntry acid
|
|
||||||
, dir "entry" $ path $ \(entry :: Integer) -> msum [
|
|
||||||
method GET >> editEntry acid entry
|
|
||||||
, method POST >> updateEntry acid entry ]
|
|
||||||
, dir "entrylist" $ path $ \(lang :: BlogLang) -> entryList acid lang
|
|
||||||
, ok $ toResponse $ adminIndex "tazjin"
|
|
||||||
]
|
|
||||||
|
|
||||||
showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
|
||||||
showEntry acid lang eId = do
|
|
||||||
entry <- query' acid (GetEntry eId)
|
|
||||||
tryEntry entry lang
|
tryEntry entry lang
|
||||||
|
|
||||||
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
|
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
|
||||||
|
|
@ -84,107 +68,19 @@ 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
|
||||||
|
|
||||||
showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
|
offset :: Maybe Integer -> Integer
|
||||||
showIndex acid lang = do
|
offset = maybe 0 ((*) pageSize)
|
||||||
entries <- query' acid (LatestEntries lang)
|
|
||||||
(page :: Maybe Int) <- optional $ lookRead "page"
|
|
||||||
ok $ toResponse $ blogTemplate lang "" $
|
|
||||||
renderEntries False (eDrop page entries) (Just $ showLinks page lang)
|
|
||||||
where
|
|
||||||
eDrop :: Maybe Int -> [a] -> [a]
|
|
||||||
eDrop (Just i) = drop ((i-1) * 6)
|
|
||||||
eDrop Nothing = drop 0
|
|
||||||
|
|
||||||
showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
|
showIndex :: BlogCache -> BlogLang -> ServerPart Response
|
||||||
showRSS acid lang = do
|
showIndex cache lang = do
|
||||||
entries <- query' acid (LatestEntries lang)
|
(page :: Maybe Integer) <- optional $ lookRead "page"
|
||||||
feed <- liftIO $ renderFeed lang $ take 6 entries
|
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"
|
setHeaderM "content-type" "text/xml"
|
||||||
ok $ toResponse feed
|
ok $ toResponse feed
|
||||||
|
|
||||||
{- ADMIN stuff -}
|
|
||||||
|
|
||||||
postEntry :: AcidState Blog -> ServerPart Response
|
|
||||||
postEntry acid = do
|
|
||||||
nullDir
|
|
||||||
decodeBody tmpPolicy
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
let eId = timeToId now
|
|
||||||
lang <- look "lang"
|
|
||||||
nBtext <- lookText' "btext"
|
|
||||||
nMtext <- lookText' "mtext"
|
|
||||||
nEntry <- Entry <$> pure eId
|
|
||||||
<*> getLang lang
|
|
||||||
<*> readCookieValue "sUser"
|
|
||||||
<*> lookText' "title"
|
|
||||||
<*> pure nBtext
|
|
||||||
<*> pure nMtext
|
|
||||||
<*> pure now
|
|
||||||
update' acid (InsertEntry nEntry)
|
|
||||||
seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse())
|
|
||||||
where
|
|
||||||
timeToId :: UTCTime -> EntryId
|
|
||||||
timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
|
|
||||||
getLang :: String -> ServerPart BlogLang
|
|
||||||
getLang "de" = return DE
|
|
||||||
getLang _ = return EN -- English is default
|
|
||||||
|
|
||||||
entryList :: AcidState Blog -> BlogLang -> ServerPart Response
|
|
||||||
entryList acid lang = do
|
|
||||||
entries <- query' acid (LatestEntries lang)
|
|
||||||
ok $ toResponse $ adminEntryList entries
|
|
||||||
|
|
||||||
editEntry :: AcidState Blog -> Integer -> ServerPart Response
|
|
||||||
editEntry acid entryId = do
|
|
||||||
entry <- query' acid (GetEntry $ EntryId entryId)
|
|
||||||
ok $ toResponse $ editPage $ fromJust entry
|
|
||||||
|
|
||||||
updateEntry :: AcidState Blog -> Integer -> ServerPart Response
|
|
||||||
updateEntry acid entryId = do
|
|
||||||
decodeBody tmpPolicy
|
|
||||||
entry <- query' acid (GetEntry $ EntryId entryId)
|
|
||||||
nTitle <- lookText' "title"
|
|
||||||
nBtext <- lookText' "btext"
|
|
||||||
nMtext <- lookText' "mtext"
|
|
||||||
let newEntry = (fromJust entry)
|
|
||||||
{ title = nTitle
|
|
||||||
, btext = nBtext
|
|
||||||
, mtext = nMtext}
|
|
||||||
update' acid (UpdateEntry newEntry)
|
|
||||||
seeOther (concat $ ["/", show $ lang newEntry, "/", show entryId])
|
|
||||||
(toResponse ())
|
|
||||||
|
|
||||||
guardSession :: AcidState Blog -> ServerPartT IO ()
|
|
||||||
guardSession acid = do
|
|
||||||
(sId :: Text) <- readCookieValue "session"
|
|
||||||
(uName :: Text) <- readCookieValue "sUser"
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
mS <- query' acid (GetSession $ SessionID sId)
|
|
||||||
case mS of
|
|
||||||
Nothing -> mzero
|
|
||||||
(Just Session{..}) -> unless ((uName == username user) && sessionTimeDiff now sdate)
|
|
||||||
mzero
|
|
||||||
where
|
|
||||||
sessionTimeDiff :: UTCTime -> UTCTime -> Bool
|
|
||||||
sessionTimeDiff now sdate = diffUTCTime now sdate < 43200
|
|
||||||
|
|
||||||
|
|
||||||
processLogin :: AcidState Blog -> ServerPart Response
|
|
||||||
processLogin acid = do
|
|
||||||
decodeBody tmpPolicy
|
|
||||||
account <- lookText' "account"
|
|
||||||
password <- look "password"
|
|
||||||
login <- query' acid (CheckUser (Username account) password)
|
|
||||||
if login
|
|
||||||
then createSession account
|
|
||||||
else unauthorized $ toResponse adminLogin
|
|
||||||
where
|
|
||||||
createSession account = do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
let sId = hashString $ show now
|
|
||||||
addCookie (MaxAge 43200) (mkCookie "session" $ unpack sId)
|
|
||||||
addCookie (MaxAge 43200) (mkCookie "sUser" $ T.unpack account)
|
|
||||||
user <- query' acid (GetUser $ Username account)
|
|
||||||
let nSession = Session (T.pack $ unpack sId) (fromJust user) now
|
|
||||||
update' acid (AddSession nSession)
|
|
||||||
seeOther ("/admin?do=login" :: Text) (toResponse())
|
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
Name: tazblog
|
Name: tazblog
|
||||||
Version: 5.1.3
|
Version: 6.0.0
|
||||||
Synopsis: Tazjin's Blog
|
Synopsis: Tazjin's Blog
|
||||||
License: MIT
|
License: MIT
|
||||||
Author: Vincent Ambo
|
Author: Vincent Ambo
|
||||||
Maintainer: tazjin@gmail.com
|
Maintainer: mail@tazj.in
|
||||||
Category: Web blog
|
Category: Web blog
|
||||||
Build-type: Simple
|
Build-type: Simple
|
||||||
cabal-version: >= 1.10
|
cabal-version: >= 1.10
|
||||||
|
|
@ -12,7 +12,7 @@ library
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -W
|
ghc-options: -W
|
||||||
exposed-modules: Blog, BlogDB, Locales, Server, RSS
|
exposed-modules: Blog, BlogStore, Locales, Server, RSS
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
bytestring,
|
bytestring,
|
||||||
happstack-server,
|
happstack-server,
|
||||||
|
|
@ -24,9 +24,6 @@ library
|
||||||
old-locale,
|
old-locale,
|
||||||
time,
|
time,
|
||||||
base64-bytestring,
|
base64-bytestring,
|
||||||
acid-state,
|
|
||||||
ixset,
|
|
||||||
safecopy,
|
|
||||||
mtl,
|
mtl,
|
||||||
transformers,
|
transformers,
|
||||||
network,
|
network,
|
||||||
|
|
@ -53,18 +50,6 @@ executable tazblog
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
acid-state,
|
|
||||||
tazblog,
|
|
||||||
options,
|
|
||||||
network
|
|
||||||
|
|
||||||
executable tazblog-db
|
|
||||||
hs-source-dirs: db
|
|
||||||
main-is: Main.hs
|
|
||||||
default-language: Haskell2010
|
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
|
||||||
build-depends: base,
|
|
||||||
acid-state,
|
|
||||||
tazblog,
|
tazblog,
|
||||||
options,
|
options,
|
||||||
network
|
network
|
||||||
|
|
|
||||||
|
|
@ -6,17 +6,17 @@
|
||||||
}:
|
}:
|
||||||
mkDerivation {
|
mkDerivation {
|
||||||
pname = "tazblog";
|
pname = "tazblog";
|
||||||
version = "5.1.3";
|
version = "6.0.0";
|
||||||
src = ./.;
|
src = ./.;
|
||||||
isLibrary = true;
|
isLibrary = true;
|
||||||
isExecutable = true;
|
isExecutable = true;
|
||||||
libraryHaskellDepends = [
|
libraryHaskellDepends = [
|
||||||
acid-state base base64-bytestring blaze-html blaze-markup
|
base base64-bytestring blaze-html blaze-markup bytestring
|
||||||
bytestring crypto-api cryptohash hamlet happstack-server ixset
|
crypto-api cryptohash hamlet happstack-server markdown mtl
|
||||||
markdown mtl network network-uri old-locale rss safecopy
|
network network-uri old-locale rss shakespeare text time
|
||||||
shakespeare text time transformers
|
transformers
|
||||||
];
|
];
|
||||||
executableHaskellDepends = [ acid-state base network options ];
|
executableHaskellDepends = [ base network options ];
|
||||||
description = "Tazjin's Blog";
|
description = "Tazjin's Blog";
|
||||||
license = stdenv.lib.licenses.mit;
|
license = stdenv.lib.licenses.mit;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue