diff --git a/LICENSE b/LICENSE
new file mode 100644
index 000000000..904a76ed0
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2019 Vincent Ambo
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/services/tazblog/.gitignore b/services/tazblog/.gitignore
new file mode 100644
index 000000000..a95070c31
--- /dev/null
+++ b/services/tazblog/.gitignore
@@ -0,0 +1,7 @@
+*.o
+*.hi
+BlogState/
+dist/
+.cabal-sandbox/
+*.tar.gz
+.stack-work/
diff --git a/services/tazblog/.stylish.haskell.yaml b/services/tazblog/.stylish.haskell.yaml
new file mode 100644
index 000000000..cb432ce23
--- /dev/null
+++ b/services/tazblog/.stylish.haskell.yaml
@@ -0,0 +1,20 @@
+steps:
+ - imports:
+ align: group
+ - language_pragmas:
+ style: vertical
+ remove_redundant: true
+ - records: {}
+ - trailing_whitespace: {}
+columns: 120
+language_extensions:
+ - DeriveDataTypeable
+ - FlexibleContexts
+ - GeneralizedNewtypeDeriving
+ - MultiParamTypeClasses
+ - OverloadedStrings
+ - RecordWildCards
+ - ScopedTypeVariables
+ - TemplateHaskell
+ - TypeFamilies
+ - QuasiQuotes
diff --git a/services/tazblog/blog/Main.hs b/services/tazblog/blog/Main.hs
new file mode 100644
index 000000000..cfe068a8d
--- /dev/null
+++ b/services/tazblog/blog/Main.hs
@@ -0,0 +1,41 @@
+-- | Main module for the blog's web server
+module Main where
+
+import BlogDB (initialBlogState)
+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 (..))
+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"
+ "Resources folder location."
+
+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))
+
+
diff --git a/services/tazblog/db/Main.hs b/services/tazblog/db/Main.hs
new file mode 100644
index 000000000..9523041f1
--- /dev/null
+++ b/services/tazblog/db/Main.hs
@@ -0,0 +1,34 @@
+-- | 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
diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs
new file mode 100644
index 000000000..f35e3d908
--- /dev/null
+++ b/services/tazblog/src/Blog.hs
@@ -0,0 +1,234 @@
+module Blog where
+
+import BlogDB
+import Data.Maybe (fromJust)
+import Data.Text (Text, append, 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
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y = map (\z -> if z == x then y else z)
+
+show' :: Show a => a -> Text
+show' = pack . show
+
+-- |After this time all entries are Markdown
+markdownCutoff :: UTCTime
+markdownCutoff = fromJust $ parseTimeM False defaultTimeLocale "%s" "1367149834"
+
+-- blog HTML
+blogTemplate :: BlogLang -> Text -> Html -> Html
+blogTemplate lang t_append body = [shamlet|
+$doctype 5
+
+
+
+
+
+
+ #{blogTitle lang t_append}
+ <body>
+ <header>
+ <h1>
+ <a href="/" .unstyled-link>#{blogTitle lang empty}
+ <hr>
+ ^{body}
+ ^{showFooter}
+|]
+ where
+ rssUrl = T.concat ["/", show' lang, "/rss.xml"]
+
+showFooter :: Html
+showFooter = [shamlet|
+<footer>
+ <p .footer>Served without any dynamic languages.
+ <p .footer>
+ <a href=#{repoURL} .uncoloured-link>Version #{version}
+ |
+ <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 :: Bool -> [Entry] -> Maybe Html -> Html
+renderEntries showAll entries pageLinks = [shamlet|
+$forall entry <- toDisplay
+ <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 $ btext entry}
+ $else
+ ^{preEscapedToHtml $ btext entry}
+ $if ((/=) (mtext entry) empty)
+ <p>
+ <a .uncoloured-link href=#{linkElems entry}>
+ #{readMore $ lang entry}
+ <hr>
+$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 (Just i) lang = [shamlet|
+ $if ((>) i 1)
+ <div .navigation>
+ <a href=#{nLink $ succ i} .uncoloured-link>#{backText lang}
+ |
+ <a href=#{nLink $ pred i} .uncoloured-link>#{nextText lang}
+ $elseif ((<=) i 1)
+ ^{showLinks Nothing lang}
+|]
+ where
+ 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"]
+
+renderEntry :: Entry -> Html
+renderEntry e@Entry{..} = [shamlet|
+<article>
+ <h2 .inline>
+ #{title}
+ <aside .date>
+ #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" edate}
+ $if (isEntryMarkdown e)
+ ^{renderEntryMarkdown btext}
+ <p>^{renderEntryMarkdown $ mtext}
+ $else
+ ^{preEscapedToHtml $ btext}
+ <p>^{preEscapedToHtml $ mtext}
+<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>:(
+<p>#{notFoundText l}
+<hr>
+|]
+showError UnknownError l = blogTemplate l "" $ [shamlet|
+<p>:(
+<p>#{unknownErrorText l}
+<hr>
+|]
diff --git a/services/tazblog/src/BlogDB.hs b/services/tazblog/src/BlogDB.hs
new file mode 100644
index 000000000..bc9c24393
--- /dev/null
+++ b/services/tazblog/src/BlogDB.hs
@@ -0,0 +1,229 @@
+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
diff --git a/services/tazblog/src/Locales.hs b/services/tazblog/src/Locales.hs
new file mode 100644
index 000000000..c1ddcb38f
--- /dev/null
+++ b/services/tazblog/src/Locales.hs
@@ -0,0 +1,61 @@
+module Locales where
+
+import BlogDB (BlogLang (..))
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.URI
+
+data BlogError = NotFound | UnknownError
+
+version = "5.1.2"
+
+blogTitle :: BlogLang -> Text -> Text
+blogTitle DE s = T.concat ["Tazjins blog", s]
+blogTitle EN s = T.concat ["Tazjin's blog", s]
+
+showLangText :: BlogLang -> Text
+showLangText EN = "en"
+showLangText DE = "de"
+
+backText :: BlogLang -> Text
+backText DE = "Früher"
+backText EN = "Earlier"
+
+nextText :: BlogLang -> Text
+nextText DE = "Später"
+nextText EN = "Later"
+
+readMore :: BlogLang -> Text
+readMore DE = "[Weiterlesen]"
+readMore EN = "[Read more]"
+
+-- RSS Strings
+rssTitle :: BlogLang -> String
+rssTitle DE = "Tazjins Blog"
+rssTitle EN = "Tazjin's Blog"
+
+rssDesc :: BlogLang -> String
+rssDesc DE = "Feed zu Tazjins Blog"
+rssDesc EN = "Feed for Tazjin's Blog"
+
+rssLink :: BlogLang -> URI
+rssLink l = fromMaybe nullURI $ parseURI ("http://tazj.in/" ++ show l)
+
+-- errors
+notFoundTitle :: BlogLang -> Text
+notFoundTitle DE = "Nicht gefunden"
+notFoundTitle EN = "Not found"
+
+notFoundText :: BlogLang -> Text
+notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden."
+notFoundText EN = "The requested object could not be found."
+
+unknownErrorText :: BlogLang -> Text
+unknownErrorText DE = "Ein unbekannter Fehler ist aufgetreten."
+unknownErrorText EN = "An unknown error has occured."
+
+-- static information
+repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
+mailTo :: Text = "mailto:tazjin+blog@gmail.com"
+twitter :: Text = "https://twitter.com/tazjin"
diff --git a/services/tazblog/src/RSS.hs b/services/tazblog/src/RSS.hs
new file mode 100644
index 000000000..34804cbf0
--- /dev/null
+++ b/services/tazblog/src/RSS.hs
@@ -0,0 +1,41 @@
+module RSS (renderFeed) where
+
+import qualified Data.Text as T
+
+import Control.Monad (liftM)
+import Data.Maybe (fromMaybe)
+import Data.Time (UTCTime, getCurrentTime)
+import Network.URI
+import Text.RSS
+
+import BlogDB hiding (Title)
+import Locales
+
+createChannel :: BlogLang -> UTCTime -> [ChannelElem]
+createChannel l now = [ Language $ show l
+ , Copyright "Vincent Ambo"
+ , WebMaster "tazjin@gmail.com"
+ , 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 edate]
+
+makeLink :: BlogLang -> EntryId -> URI
+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 )
+
+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
new file mode 100644
index 000000000..c025be009
--- /dev/null
+++ b/services/tazblog/src/Server.hs
@@ -0,0 +1,189 @@
+-- Server implementation based on Happstack
+
+module Server where
+
+import Control.Applicative (optional)
+import Control.Monad (msum, mzero, unless)
+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 Blog
+import BlogDB hiding (updateEntry)
+import Locales
+import RSS
+
+instance FromReqURI BlogLang where
+ fromReqURI sub =
+ case map toLower sub of
+ "de" -> Just DE
+ "en" -> Just EN
+ _ -> Nothing
+
+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
+
+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 ]
+ , dir "static" $ staticHandler resDir
+ , blogHandler acid 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
+ , notFound $ toResponse $ showError NotFound lang
+ ]
+
+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
+
+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)
+ 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
+
+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
+
+showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
+showRSS acid lang = do
+ entries <- query' acid (LatestEntries lang)
+ feed <- liftIO $ renderFeed lang $ take 6 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
+ (Just entry) <- query' acid (GetEntry $ EntryId entryId)
+ ok $ toResponse $ editPage entry
+
+updateEntry :: AcidState Blog -> Integer -> ServerPart Response
+updateEntry acid entryId = do
+ decodeBody tmpPolicy
+ (Just entry) <- query' acid (GetEntry $ EntryId entryId)
+ nTitle <- lookText' "title"
+ nBtext <- lookText' "btext"
+ nMtext <- lookText' "mtext"
+ let newEntry = entry { title = nTitle
+ , btext = nBtext
+ , mtext = nMtext}
+ update' acid (UpdateEntry newEntry)
+ seeOther (concat $ ["/", show $ lang entry, "/", 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)
+ (Just user) <- query' acid (GetUser $ Username account)
+ let nSession = Session (T.pack $ unpack sId) user now
+ update' acid (AddSession nSession)
+ seeOther ("/admin?do=login" :: Text) (toResponse())
diff --git a/services/tazblog/static/admin.css b/services/tazblog/static/admin.css
new file mode 100644
index 000000000..10980dc9e
--- /dev/null
+++ b/services/tazblog/static/admin.css
@@ -0,0 +1,49 @@
+@charset "UTF-8";
+/* CSS Document */
+
+body {
+ padding-top: 20px;
+ font-family: 'PT Sans', sans-serif;
+ background-image: linear-gradient(bottom, rgb(245,245,245) 66%, rgb(239,239,239) 83%);
+ background-image: -o-linear-gradient(bottom, rgb(245,245,245) 66%, rgb(239,239,239) 83%);
+ background-image: -webkit-linear-gradient(bottom, rgb(245,245,245) 66%, rgb(239,239,239) 83%);
+ background-image: -webkit-gradient(
+ linear,
+ left bottom,
+ left top,
+ color-stop(0.66, rgb(245,245,245)),
+ color-stop(0.83, rgb(239,239,239))
+ );
+ background-repeat: no-repeat;
+ background-color: rgb(245,245,245);
+}
+
+.loginBox {
+ width: 400px;
+ margin: 0 auto;
+}
+
+.loginBoxTop {
+ width: 380px;
+ height: 28px;
+ color: #FFFFFF;
+ font-size: 12px;
+ padding-left: 20px;
+ padding-top: 11px;
+ background: url(/static/loginBoxTop.png);
+}
+
+.loginBoxMiddle {
+ background-color: #F3F3F3;
+ border-top: 0px hidden;
+ border:1px solid #D2D2D2;
+ border-bottom-left-radius: 12px;
+ border-bottom-right-radius: 12px;
+ text-align: center;
+ font-size:12px;
+ height:auto;
+ padding-left: 10px;
+ padding-right: 10px;
+ min-height:200px;
+ width:378px;
+}
diff --git a/services/tazblog/static/apple-touch-icon.png b/services/tazblog/static/apple-touch-icon.png
new file mode 100644
index 000000000..22ba058cd
Binary files /dev/null and b/services/tazblog/static/apple-touch-icon.png differ
diff --git a/services/tazblog/static/blog.css b/services/tazblog/static/blog.css
new file mode 100644
index 000000000..e6e4ae3c2
--- /dev/null
+++ b/services/tazblog/static/blog.css
@@ -0,0 +1,35 @@
+body {
+ margin: 40px auto;
+ max-width: 650px;
+ line-height: 1.6;
+ font-size: 18px;
+ color: #383838;
+ padding: 0 10px
+}
+h1, h2, h3 {
+ line-height: 1.2
+}
+.footer {
+ text-align: right;
+}
+.lod {
+ text-align: center;
+}
+.unstyled-link {
+ color: inherit;
+ text-decoration: none;
+}
+.uncoloured-link {
+ color: inherit;
+}
+.date {
+ text-align: right;
+ font-style: italic;
+ float: right;
+}
+.inline {
+ display: inline;
+}
+.navigation {
+ text-align: center;
+}
diff --git a/services/tazblog/static/favicon.ico b/services/tazblog/static/favicon.ico
new file mode 100644
index 000000000..2958dd3af
Binary files /dev/null and b/services/tazblog/static/favicon.ico differ
diff --git a/services/tazblog/static/keybase.txt b/services/tazblog/static/keybase.txt
new file mode 100644
index 000000000..661c33e01
--- /dev/null
+++ b/services/tazblog/static/keybase.txt
@@ -0,0 +1,69 @@
+==================================================================
+https://keybase.io/tazjin
+--------------------------------------------------------------------
+
+I hereby claim:
+
+ * I am an admin of http://tazj.in
+ * I am tazjin (https://keybase.io/tazjin) on keybase.
+ * I have a public key with fingerprint DCF3 4CFA C1AC 44B8 7E26 3331 36EE 3481 4F6D 294A
+
+To claim this, I am signing this object:
+
+{
+ "body": {
+ "key": {
+ "fingerprint": "dcf34cfac1ac44b87e26333136ee34814f6d294a",
+ "host": "keybase.io",
+ "key_id": "36EE34814F6D294A",
+ "uid": "2268b75a56bb9693d3ef077bc1217900",
+ "username": "tazjin"
+ },
+ "service": {
+ "hostname": "tazj.in",
+ "protocol": "http:"
+ },
+ "type": "web_service_binding",
+ "version": 1
+ },
+ "ctime": 1397644545,
+ "expire_in": 157680000,
+ "prev": "4973fdda56a6cfa726a813411c915458c652be45dd19283f7a4ae4f9c217df14",
+ "seqno": 4,
+ "tag": "signature"
+}
+
+with the aforementioned key, yielding the PGP signature:
+
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v2.0.22 (GNU/Linux)
+
+owGbwMvMwMWY9pU1Q3bHF2vG0wdeJTEE+8WyVSsl5adUKllVK2Wngqm0zLz01KKC
+osy8EiUrpZTkNGOT5LTEZMPEZBOTJAvzVCMzY2NjQ2Oz1FRjEwtDkzSzFCNLk0Ql
+HaWM/GKQDqAxSYnFqXqZ+UAxICc+MwUoamzm6gpW72bmAlTvCJQrBUsYGZlZJJmb
+JpqaJSVZmlkapxinphmYmyclGxoZmlsaGIAUFqcW5SXmpgJVlyRWZWXmKdXqKAHF
+yjKTU0EuBlmMJK8HVKCjVFCUX5KfnJ8DFMwoKSmwAukpqSwAKSpPTYqHao9PysxL
+AXoYqKEstag4Mz9PycoQqDK5JBNknqGxpbmZiYmpiamOUmpFQWZRanwmSIWpuZmF
+ARCArEktAxppYmlunJaSAvRFohkwtMyNzBItDI1NDA2TLQ2Bui2SzUyNklJNTFNS
+DC2NLIzTzBNNElNN0iyTgZ5MSTM0UQJ5qDAvX8nKBOjMxHSgkcWZ6XmJJaVFqUq1
+nUwyLAyMXAxsrEygKGPg4hSARWSZH/8/0573HMdvfH5XxeayYZ2efPb8bw730i1/
+WBU3qru5pKlf3xKmeK5ihtKeT6VXGm3usV2reZWyvO/0joi83oT9P80s88Q6U/vb
+vmycHnB7e110v/3OZadu/Sx6+uXk/ZeCR8u+p/+6dNc8XWqX/68t06pnrGKU/BfU
+F7X5S/HUy4ysvyZN+v1Jj6NtMvvN1EvPpCpv3kz2tGU1EzpZFfl8Xujq1OopuxZJ
+l5kvDlgZ78ezdLZ1+aOlixbsXra4/3fdbZ8XnQX1DatzV18+e2rmMcPKm6qngqIf
+Xp8oKTAz+Mg1v6gHP0wLN/Mf3JKjYHnX5U6L/KIvkbsLArtES0r7w1iWZ3OvvSPr
+fW6heune1tOb7j3vP+1XeOyV2ekr6pPO3bdrv9X25HbTaqs7z06f0v35fmtQ3uUZ
+Z35eLYmaEmb/x/u3vFh6GsvMDocpCTpPlHa0z+xzOGbhzLFO18v21Zd9ISG3Hqtd
+F7jaLlWa2W+TsytNnXudVrfCBSbl8zNMfuk2e0Z8i9ix3PmEVa3rTEfhde3qwgtY
+dy8rUbzzd5d9ccF63btqO/VMb4oe04x4uCLB5RD3p+8+s77o/T4WP2cFw+0cviX6
+StlJX5f+U3Or3fZY7dUfPcmMJZ/eSs7m+1d5IUbs3jI27olHFzGVvTcsu7w79aOK
+SxmXvnEIUwZXgP6BL4LrPDY1rN2V0q1cZj1/efj880rzeu6+OQYA
+=xHfH
+-----END PGP MESSAGE-----
+
+And finally, I am proving ownership of this host by posting or
+appending to this document.
+
+View my publicly-auditable identity here: https://keybase.io/tazjin
+
+==================================================================
diff --git a/services/tazblog/static/loginBoxTop.png b/services/tazblog/static/loginBoxTop.png
new file mode 100644
index 000000000..8a0ee3ba8
Binary files /dev/null and b/services/tazblog/static/loginBoxTop.png differ
diff --git a/services/tazblog/static/signin.gif b/services/tazblog/static/signin.gif
new file mode 100644
index 000000000..bbe282bae
Binary files /dev/null and b/services/tazblog/static/signin.gif differ
diff --git a/services/tazblog/tazblog.cabal b/services/tazblog/tazblog.cabal
new file mode 100644
index 000000000..3ca9d373b
--- /dev/null
+++ b/services/tazblog/tazblog.cabal
@@ -0,0 +1,71 @@
+Name: tazblog
+Version: 5.1.3
+Synopsis: Tazjin's Blog
+License: MIT
+License-file: LICENSE
+Author: Vincent Ambo
+Maintainer: tazjin@gmail.com
+Category: Web blog
+Build-type: Simple
+cabal-version: >= 1.10
+
+library
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -W
+ exposed-modules: Blog, BlogDB, Locales, Server, RSS
+ build-depends: base,
+ bytestring,
+ happstack-server,
+ text,
+ blaze-html,
+ blaze-markup,
+ crypto-api,
+ cryptohash,
+ old-locale,
+ time,
+ base64-bytestring,
+ acid-state,
+ ixset,
+ safecopy,
+ mtl,
+ transformers,
+ network,
+ network-uri,
+ rss,
+ hamlet,
+ shakespeare,
+ markdown
+ default-extensions:
+ DeriveDataTypeable
+ FlexibleContexts
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ ScopedTypeVariables
+ TemplateHaskell
+ TypeFamilies
+ QuasiQuotes
+
+executable tazblog
+ hs-source-dirs: blog
+ main-is: Main.hs
+ 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