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
|
||||
module Main where
|
||||
|
||||
import BlogDB (initialBlogState)
|
||||
import Control.Applicative (pure, (<$>), (<*>))
|
||||
import Control.Applicative (pure, (<*>))
|
||||
import Control.Exception (bracket)
|
||||
import Data.Acid
|
||||
import Data.Acid.Remote
|
||||
import Data.Word (Word16)
|
||||
import Locales (version)
|
||||
import Network (HostName, PortID (..))
|
||||
|
|
@ -13,18 +10,12 @@ import Options
|
|||
import Server
|
||||
|
||||
data MainOptions = MainOptions {
|
||||
dbHost :: String,
|
||||
dbPort :: Word16,
|
||||
blogPort :: Int,
|
||||
resourceDir :: String
|
||||
}
|
||||
|
||||
instance Options MainOptions where
|
||||
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
|
||||
"Port to serve the blog on. Default is 8000."
|
||||
<*> simpleOption "resourceDir" "/opt/tazblog/static"
|
||||
|
|
@ -34,8 +25,4 @@ main :: IO()
|
|||
main = do
|
||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||
runCommand $ \opts _ ->
|
||||
let port = PortNumber $ fromIntegral $ dbPort opts
|
||||
in openRemoteState skipAuthenticationPerform (dbHost opts) port >>=
|
||||
(\acid -> runBlog acid (blogPort opts) (resourceDir opts))
|
||||
|
||||
|
||||
runBlog (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
|
||||
|
||||
import BlogDB
|
||||
import BlogStore
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text (Text, append, empty, pack)
|
||||
import Data.Text (Text, empty, pack)
|
||||
import Data.Text.Lazy (fromStrict)
|
||||
import Data.Time
|
||||
import Locales
|
||||
|
|
@ -75,9 +75,9 @@ isEntryMarkdown e = edate e > markdownCutoff
|
|||
renderEntryMarkdown :: Text -> Html
|
||||
renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
|
||||
|
||||
renderEntries :: Bool -> [Entry] -> Maybe Html -> Html
|
||||
renderEntries showAll entries pageLinks = [shamlet|
|
||||
$forall entry <- toDisplay
|
||||
renderEntries :: [Entry] -> Maybe Html -> Html
|
||||
renderEntries entries pageLinks = [shamlet|
|
||||
$forall entry <- entries
|
||||
<article>
|
||||
<h2 .inline>
|
||||
<a href=#{linkElems entry} .unstyled-link>
|
||||
|
|
@ -97,10 +97,9 @@ $maybe links <- pageLinks
|
|||
^{links}
|
||||
|]
|
||||
where
|
||||
toDisplay = if showAll then entries else (take 6 entries)
|
||||
linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
|
||||
|
||||
showLinks :: Maybe Int -> BlogLang -> Html
|
||||
showLinks :: Maybe Integer -> BlogLang -> Html
|
||||
showLinks (Just i) lang = [shamlet|
|
||||
$if ((>) i 1)
|
||||
<div .navigation>
|
||||
|
|
@ -135,103 +134,6 @@ renderEntry e@Entry{..} = [shamlet|
|
|||
<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 NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet|
|
||||
<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 #-}
|
||||
module Locales where
|
||||
|
||||
import BlogDB (BlogLang (..))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Network.URI
|
||||
|
||||
data BlogLang = EN | DE
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show BlogLang where
|
||||
show DE = "de"
|
||||
show EN = "en"
|
||||
|
||||
data BlogError = NotFound | UnknownError
|
||||
|
||||
version = "5.1.2"
|
||||
version = "6.0.0"
|
||||
|
||||
blogTitle :: BlogLang -> Text -> Text
|
||||
blogTitle DE s = T.concat ["Tazjins blog", s]
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import Data.Time (UTCTime, getCurrentTime)
|
|||
import Network.URI
|
||||
import Text.RSS
|
||||
|
||||
import BlogDB hiding (Title)
|
||||
import BlogStore
|
||||
import Locales
|
||||
|
||||
createChannel :: BlogLang -> UTCTime -> [ChannelElem]
|
||||
|
|
|
|||
|
|
@ -2,20 +2,15 @@
|
|||
module Server where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad (msum, mzero, unless)
|
||||
import Control.Monad (msum)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Acid
|
||||
import Data.Acid.Advanced
|
||||
import Data.ByteString.Char8 (unpack)
|
||||
import Data.Char (toLower)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
import Happstack.Server hiding (Session)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Maybe (maybe)
|
||||
|
||||
import Blog
|
||||
import BlogDB hiding (updateEntry)
|
||||
import BlogStore
|
||||
import Locales
|
||||
import RSS
|
||||
|
||||
|
|
@ -26,32 +21,32 @@ instance FromReqURI BlogLang where
|
|||
"en" -> Just EN
|
||||
_ -> Nothing
|
||||
|
||||
pageSize :: Integer
|
||||
pageSize = 3
|
||||
|
||||
tmpPolicy :: BodyPolicy
|
||||
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
|
||||
|
||||
runBlog :: AcidState Blog -> Int -> String -> IO ()
|
||||
runBlog acid port respath =
|
||||
simpleHTTP nullConf {port = port} $ tazBlog acid respath
|
||||
runBlog :: Int -> String -> IO ()
|
||||
runBlog port respath = do
|
||||
cache <- newCache "blog.tazj.in."
|
||||
simpleHTTP nullConf {port = port} $ tazBlog cache respath
|
||||
|
||||
tazBlog :: AcidState Blog -> String -> ServerPart Response
|
||||
tazBlog acid resDir = do
|
||||
msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
|
||||
, dir "admin" $ msum [
|
||||
adminHandler acid -- this checks auth
|
||||
, method GET >> (ok $ toResponse adminLogin)
|
||||
, method POST >> processLogin acid ]
|
||||
tazBlog :: BlogCache -> String -> ServerPart Response
|
||||
tazBlog cache resDir = do
|
||||
msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang
|
||||
, dir "static" $ staticHandler resDir
|
||||
, blogHandler acid EN
|
||||
, blogHandler cache EN
|
||||
, staticHandler resDir
|
||||
, notFound $ toResponse $ showError NotFound DE
|
||||
]
|
||||
|
||||
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
||||
blogHandler acid lang =
|
||||
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
||||
, nullDir >> showIndex acid lang
|
||||
, dir "rss" $ nullDir >> showRSS acid lang
|
||||
, dir "rss.xml" $ nullDir >> showRSS acid lang
|
||||
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
|
||||
]
|
||||
|
||||
|
|
@ -61,20 +56,9 @@ staticHandler resDir = do
|
|||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||
serveDirectory DisableBrowsing [] resDir
|
||||
|
||||
adminHandler :: AcidState Blog -> ServerPart Response
|
||||
adminHandler acid = do
|
||||
guardSession acid
|
||||
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)
|
||||
showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
|
||||
showEntry cache lang eId = do
|
||||
entry <- getEntry cache eId
|
||||
tryEntry entry lang
|
||||
|
||||
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
|
||||
|
|
@ -84,107 +68,19 @@ tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEn
|
|||
eTitle = T.append ": " (title entry)
|
||||
eLang = lang entry
|
||||
|
||||
showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
|
||||
showIndex acid lang = do
|
||||
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
|
||||
offset :: Maybe Integer -> Integer
|
||||
offset = maybe 0 ((*) pageSize)
|
||||
|
||||
showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
|
||||
showRSS acid lang = do
|
||||
entries <- query' acid (LatestEntries lang)
|
||||
feed <- liftIO $ renderFeed lang $ take 6 entries
|
||||
showIndex :: BlogCache -> BlogLang -> ServerPart Response
|
||||
showIndex cache lang = do
|
||||
(page :: Maybe Integer) <- 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
|
||||
|
||||
{- 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
|
||||
Version: 5.1.3
|
||||
Version: 6.0.0
|
||||
Synopsis: Tazjin's Blog
|
||||
License: MIT
|
||||
Author: Vincent Ambo
|
||||
Maintainer: tazjin@gmail.com
|
||||
Maintainer: mail@tazj.in
|
||||
Category: Web blog
|
||||
Build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
|
|
@ -12,7 +12,7 @@ library
|
|||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -W
|
||||
exposed-modules: Blog, BlogDB, Locales, Server, RSS
|
||||
exposed-modules: Blog, BlogStore, Locales, Server, RSS
|
||||
build-depends: base,
|
||||
bytestring,
|
||||
happstack-server,
|
||||
|
|
@ -24,9 +24,6 @@ library
|
|||
old-locale,
|
||||
time,
|
||||
base64-bytestring,
|
||||
acid-state,
|
||||
ixset,
|
||||
safecopy,
|
||||
mtl,
|
||||
transformers,
|
||||
network,
|
||||
|
|
@ -53,18 +50,6 @@ executable tazblog
|
|||
default-language: Haskell2010
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
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,
|
||||
options,
|
||||
network
|
||||
|
|
|
|||
|
|
@ -6,17 +6,17 @@
|
|||
}:
|
||||
mkDerivation {
|
||||
pname = "tazblog";
|
||||
version = "5.1.3";
|
||||
version = "6.0.0";
|
||||
src = ./.;
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
libraryHaskellDepends = [
|
||||
acid-state base base64-bytestring blaze-html blaze-markup
|
||||
bytestring crypto-api cryptohash hamlet happstack-server ixset
|
||||
markdown mtl network network-uri old-locale rss safecopy
|
||||
shakespeare text time transformers
|
||||
base base64-bytestring blaze-html blaze-markup bytestring
|
||||
crypto-api cryptohash hamlet happstack-server markdown mtl
|
||||
network network-uri old-locale rss shakespeare text time
|
||||
transformers
|
||||
];
|
||||
executableHaskellDepends = [ acid-state base network options ];
|
||||
executableHaskellDepends = [ base network options ];
|
||||
description = "Tazjin's Blog";
|
||||
license = stdenv.lib.licenses.mit;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue