refactor: Move tazblog into monorepo structure

It's happening!
author: Vincent Ambo <tazjin@google.com> 2019-06-28T21·55+0100
committer: Vincent Ambo <tazjin@google.com> 2019-06-28T21·55+0100
commit: 2373c925e18963c6f2698ba4c45d74196f3aaaf3 (patch)
tree: 38a0c804881c71b24391129d9ca4092de1a7b583 /services/tazblog/src
parent: aeeb11f1b76729115c4db98f419cbcda1a0f7660 (diff)
5 files changed, 754 insertions, 0 deletions
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())
author	Vincent Ambo <tazjin@google.com>	2019-06-28T21·55+0100
committer	Vincent Ambo <tazjin@google.com>	2019-06-28T21·55+0100
commit	2373c925e18963c6f2698ba4c45d74196f3aaaf3 (patch)
tree	38a0c804881c71b24391129d9ca4092de1a7b583 /services/tazblog/src
parent	aeeb11f1b76729115c4db98f419cbcda1a0f7660 (diff)