diff options
| -rw-r--r-- | LICENSE | 21 | ||||
| -rw-r--r-- | services/tazblog/.gitignore | 7 | ||||
| -rw-r--r-- | services/tazblog/.stylish.haskell.yaml | 20 | ||||
| -rw-r--r-- | services/tazblog/blog/Main.hs | 41 | ||||
| -rw-r--r-- | services/tazblog/db/Main.hs | 34 | ||||
| -rw-r--r-- | services/tazblog/src/Blog.hs | 234 | ||||
| -rw-r--r-- | services/tazblog/src/BlogDB.hs | 229 | ||||
| -rw-r--r-- | services/tazblog/src/Locales.hs | 61 | ||||
| -rw-r--r-- | services/tazblog/src/RSS.hs | 41 | ||||
| -rw-r--r-- | services/tazblog/src/Server.hs | 189 | ||||
| -rw-r--r-- | services/tazblog/static/admin.css | 49 | ||||
| -rw-r--r-- | services/tazblog/static/apple-touch-icon.png | bin | 0 -> 9756 bytes | |||
| -rw-r--r-- | services/tazblog/static/blog.css | 35 | ||||
| -rw-r--r-- | services/tazblog/static/favicon.ico | bin | 0 -> 4354 bytes | |||
| -rw-r--r-- | services/tazblog/static/keybase.txt | 69 | ||||
| -rw-r--r-- | services/tazblog/static/loginBoxTop.png | bin | 0 -> 606 bytes | |||
| -rw-r--r-- | services/tazblog/static/signin.gif | bin | 0 -> 1850 bytes | |||
| -rw-r--r-- | services/tazblog/tazblog.cabal | 71 |
18 files changed, 1101 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE new file mode 100644 index 000000000000..904a76ed0488 --- /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 000000000000..a95070c31f1e --- /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 000000000000..cb432ce231ba --- /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 000000000000..cfe068a8d988 --- /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 000000000000..9523041f109a --- /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 000000000000..f35e3d90801f --- /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 + <head> + <meta charset="utf-8"> + <meta name="viewport" content="width=device-width, initial-scale=1"> + <meta name="description" content=#{blogTitle lang t_append}> + <link rel="stylesheet" type="text/css" href="/static/blog.css" media="all"> + <link rel="alternate" type="application/rss+xml" title="RSS-Feed" href=#{rssUrl}> + <title>#{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 000000000000..bc9c24393302 --- /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 000000000000..c1ddcb38faa4 --- /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 000000000000..34804cbf0a55 --- /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 000000000000..c025be009a2e --- /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 000000000000..10980dc9e4c1 --- /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 000000000000..22ba058cddd4 --- /dev/null +++ b/services/tazblog/static/apple-touch-icon.png Binary files differdiff --git a/services/tazblog/static/blog.css b/services/tazblog/static/blog.css new file mode 100644 index 000000000000..e6e4ae3c2be0 --- /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 000000000000..2958dd3afcb0 --- /dev/null +++ b/services/tazblog/static/favicon.ico Binary files differdiff --git a/services/tazblog/static/keybase.txt b/services/tazblog/static/keybase.txt new file mode 100644 index 000000000000..661c33e01e73 --- /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 000000000000..8a0ee3ba8d6f --- /dev/null +++ b/services/tazblog/static/loginBoxTop.png Binary files differdiff --git a/services/tazblog/static/signin.gif b/services/tazblog/static/signin.gif new file mode 100644 index 000000000000..bbe282bae0a4 --- /dev/null +++ b/services/tazblog/static/signin.gif Binary files differdiff --git a/services/tazblog/tazblog.cabal b/services/tazblog/tazblog.cabal new file mode 100644 index 000000000000..3ca9d373b277 --- /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 |
