chore(tazblog): Replace BlogDB with stubs for DNS-based storage r/44

Removes acid-state specific code and the former BlogDB module, in its stead the new BlogStorage module contains stubs for the functions that will be filled in with DNS-based storage. This code is unformatted and will not currently serve a working blog.
author: Vincent Ambo <tazjin@google.com> 2019-08-19T23·17+0100
committer: Vincent Ambo <tazjin@google.com> 2019-08-19T23·17+0100
commit: 11fcf6229751eb266485cbba78d30aced1787d14 (patch)
tree: 025f02ca1d1288949f69468e32d9efe795db02a7 /services/tazblog/src
parent: 1d5b53abf8da7b00ac1e58d43a30f738c157b9d3 (diff)
6 files changed, 104 insertions, 487 deletions
diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs
index 7e0f428899ac..b5d83a57699a 100644
--- a/services/tazblog/src/Blog.hs
+++ b/services/tazblog/src/Blog.hs
@@ -11,9 +11,9 @@
 
 module Blog where
 
-import           BlogDB
+import BlogStore
 import           Data.Maybe      (fromJust)
-import           Data.Text       (Text, append, empty, pack)
+import           Data.Text       (Text, empty, pack)
 import           Data.Text.Lazy  (fromStrict)
 import           Data.Time
 import           Locales
@@ -75,9 +75,9 @@ isEntryMarkdown e = edate e > markdownCutoff
 renderEntryMarkdown :: Text -> Html
 renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
 
-renderEntries :: Bool -> [Entry] -> Maybe Html -> Html
-renderEntries showAll entries pageLinks = [shamlet|
-$forall entry <- toDisplay
+renderEntries :: [Entry] -> Maybe Html -> Html
+renderEntries entries pageLinks = [shamlet|
+$forall entry <- entries
   <article>
     <h2 .inline>
       <a href=#{linkElems entry} .unstyled-link>
@@ -97,10 +97,9 @@ $maybe links <- pageLinks
   ^{links}
 |]
   where
-   toDisplay = if showAll then entries else (take 6 entries)
    linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
 
-showLinks :: Maybe Int -> BlogLang -> Html
+showLinks :: Maybe Integer -> BlogLang -> Html
 showLinks (Just i) lang = [shamlet|
   $if ((>) i 1)
     <div .navigation>
@@ -135,103 +134,6 @@ renderEntry e@Entry{..} = [shamlet|
 <hr>
 |]
 
-{- Administration pages -}
-
-adminTemplate :: Text -> Html -> Html
-adminTemplate title body = [shamlet|
-$doctype 5
-<head>
- <link rel="stylesheet" type="text/css" href="/static/admin.css" media="all">
- <meta http-equiv="content-type" content="text/html;charset=UTF-8">
- <title>#{append "TazBlog Admin: " title}
-<body>
- ^{body}
-|]
-
-adminLogin :: Html
-adminLogin = adminTemplate "Login" $ [shamlet|
-<div class="loginBox">
- <div class="loginBoxTop">TazBlog Admin: Login
- <div class="loginBoxMiddle">
-  <form action="/admin" method="POST">
-   <p>Account ID
-   <p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1">
-   <p>Passwort
-   <p><input type="password" style="font-size:2;" name="password">
-   <p><input alt="Anmelden" type="image" src="/static/signin.gif">
-|]
-
-adminIndex :: Text -> Html
-adminIndex sUser = adminTemplate "Index" $ [shamlet|
-<div style="float:center;">
- <form action="/admin/entry" method="POST">
-  <table>
-   <tr>
-    <thead><td>Title:
-    <td><input type="text" name="title">
-   <tr>
-    <thead><td>Language:
-    <td><select name="lang">
-     <option value="en">English
-     <option value="de">Deutsch
-   <tr>
-    <thead><td>Text:
-    <td>
-     <textarea name="btext" cols="100" rows="15">
-   <tr>
-    <thead>
-     <td style="vertical-align:top;">Read more:
-    <td>
-     <textarea name="mtext" cols="100" rows="15">
-  <input type="hidden" name="author" value=#{sUser}>
-  <input style="margin-left:20px;" type="submit" value="Submit">
- ^{adminFooter}
-|]
-
-adminFooter :: Html
-adminFooter = [shamlet|
-<a href="/">Front page
-\ -- #
-  <a href="/admin">New article
-\ -- Entry list: #
-  <a href="/admin/entrylist/en">EN
-\ & #
-<a href="/admin/entrylist/de">DE
-|]
-
-adminEntryList :: [Entry] -> Html
-adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
-<div style="float: center;">
- <table>
-  $forall entry <- entries
-   <tr>
-    <td><a href=#{append "/admin/entry/" (show' $ entryId entry)}>#{title entry}
-    <td>#{formatPostDate $ edate entry}
-|]
- where
-  formatPostDate = formatTime defaultTimeLocale "[On %D at %H:%M]"
-
-editPage :: Entry -> Html
-editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
-<div style="float:center;">
- <form action=#{append "/admin/entry/" (show' entryId)} method="POST">
-  <table>
-   <tr>
-    <td>Title:
-    <td>
-     <input type="text" name="title" value=#{title}>
-   <tr>
-    <td style="vertical-align:top;">Text:
-    <td>
-     <textarea name="btext" cols="100" rows="15">#{btext}
-   <tr>
-    <td style="vertical-align:top;">Read more:
-    <td>
-     <textarea name="mtext" cols="100" rows="15">#{mtext}
-  <input type="submit" style="margin-left:20px;" value="Submit">
-  <p>^{adminFooter}
-|]
-
 showError :: BlogError -> BlogLang -> Html
 showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet|
 <p>:(
diff --git a/services/tazblog/src/BlogDB.hs b/services/tazblog/src/BlogDB.hs
deleted file mode 100644
index f74f9ecd4fab..000000000000
--- a/services/tazblog/src/BlogDB.hs
+++ /dev/null
@@ -1,241 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
-
-module BlogDB where
-
-import           Control.Monad.Reader   (ask)
-import           Control.Monad.State    (get, put)
-import           Data.Acid
-import           Data.Acid.Advanced
-import           Data.Acid.Remote
-import           Data.ByteString        (ByteString)
-import           Data.Data              (Data, Typeable)
-import           Data.IxSet             (Indexable (..), IxSet, Proxy (..),
-                                         getOne, ixFun, ixSet, (@=))
-import           Data.SafeCopy          (base, deriveSafeCopy)
-import           Data.Text              (Text, pack)
-import           Data.Time
-import           Network                (PortID (..))
-import           System.Environment     (getEnv)
-
-import qualified Crypto.Hash.SHA512     as SHA (hash)
-import qualified Data.ByteString.Base64 as B64 (encode)
-import qualified Data.ByteString.Char8  as B
-import qualified Data.IxSet             as IxSet
-
-newtype EntryId = EntryId { unEntryId :: Integer }
-    deriving (Eq, Ord, Data, Enum, Typeable)
-
-$(deriveSafeCopy 2 'base ''EntryId)
-
-instance Show EntryId where
-  show = show . unEntryId
-
-data BlogLang = EN | DE
-    deriving (Eq, Ord, Data, Typeable)
-
-instance Show BlogLang where
-    show DE = "de"
-    show EN = "en"
-
-$(deriveSafeCopy 0 'base ''BlogLang)
-
-data Entry = Entry {
-    entryId :: EntryId,
-    lang    :: BlogLang,
-    author  :: Text,
-    title   :: Text,
-    btext   :: Text,
-    mtext   :: Text,
-    edate   :: UTCTime
-} deriving (Eq, Ord, Show, Data, Typeable)
-
-$(deriveSafeCopy 2 'base ''Entry)
-
--- ixSet requires different datatypes for field indexes, so let's define some
-newtype Author = Author Text   deriving (Eq, Ord, Data, Typeable)
-newtype Title  = Title Text    deriving (Eq, Ord, Data, Typeable)
-newtype BText  = BText Text    deriving (Eq, Ord, Data, Typeable) -- standard text
-newtype MText  = MText Text    deriving (Eq, Ord, Data, Typeable) -- "read more" text
-newtype Tag    = Tag Text      deriving (Eq, Ord, Data, Typeable)
-newtype EDate  = EDate UTCTime deriving (Eq, Ord, Data, Typeable)
-newtype SDate  = SDate UTCTime   deriving (Eq, Ord, Data, Typeable)
-newtype Username = Username Text deriving (Eq, Ord, Data, Typeable)
-newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable)
-
-$(deriveSafeCopy 2 'base ''Author)
-$(deriveSafeCopy 2 'base ''Title)
-$(deriveSafeCopy 2 'base ''BText)
-$(deriveSafeCopy 2 'base ''MText)
-$(deriveSafeCopy 2 'base ''Tag)
-$(deriveSafeCopy 2 'base ''EDate)
-$(deriveSafeCopy 2 'base ''SDate)
-$(deriveSafeCopy 2 'base ''Username)
-$(deriveSafeCopy 2 'base ''SessionID)
-
-instance Indexable Entry where
-    empty = ixSet [ ixFun $ \e -> [ entryId e]
-                  , ixFun $ (:[]) . lang
-                  , ixFun $ \e -> [ Author $ author e ]
-                  , ixFun $ \e -> [ Title $ title e]
-                  , ixFun $ \e -> [ BText $ btext e]
-                  , ixFun $ \e -> [ MText $ mtext e]
-                  , ixFun $ \e -> [ EDate $ edate e]
-                  ]
-
-data User = User {
-    username :: Text,
-    password :: ByteString
-} deriving (Eq, Ord, Data, Typeable)
-
-$(deriveSafeCopy 0 'base ''User)
-
-data Session = Session {
-    sessionID :: Text,
-    user      :: User,
-    sdate     :: UTCTime
-} deriving (Eq, Ord, Data, Typeable)
-
-$(deriveSafeCopy 0 'base ''Session)
-
-instance Indexable User where
-    empty = ixSet [ ixFun $ \u -> [Username $ username u]
-                  , ixFun $ (:[]) . password
-                  ]
-
-instance Indexable Session where
-    empty = ixSet [ ixFun $ \s -> [SessionID $ sessionID s]
-                  , ixFun $ (:[]) . user
-                  , ixFun $ \s -> [SDate $ sdate s]
-                  ]
-
-data Blog = Blog {
-    blogSessions :: IxSet Session,
-    blogUsers    :: IxSet User,
-    blogEntries  :: IxSet Entry
-} deriving (Data, Typeable)
-
-$(deriveSafeCopy 0 'base ''Blog)
-
-initialBlogState :: Blog
-initialBlogState =
-    Blog { blogSessions = empty
-         , blogUsers = empty
-         , blogEntries = empty }
-
--- acid-state database functions (purity is necessary!)
-
-insertEntry :: Entry -> Update Blog Entry
-insertEntry e =
-    do b@Blog{..} <- get
-       put $ b { blogEntries = IxSet.insert e blogEntries }
-       return e
-
-updateEntry :: Entry -> Update Blog Entry
-updateEntry e =
-    do b@Blog{..} <- get
-       put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries }
-       return e
-
-deleteEntry :: EntryId -> Update Blog EntryId
-deleteEntry entry =
-    do b@Blog{..} <- get
-       put $ b { blogEntries = IxSet.deleteIx entry blogEntries }
-       return entry
-
-getEntry :: EntryId -> Query Blog (Maybe Entry)
-getEntry eId =
-    do Blog{..} <- ask
-       return $ getOne $ blogEntries @= eId
-
-latestEntries :: BlogLang -> Query Blog [Entry]
-latestEntries lang =
-    do Blog{..} <- ask
-       return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang
-
-addSession :: Session -> Update Blog Session
-addSession nSession =
-    do b@Blog{..} <- get
-       put $ b { blogSessions = IxSet.insert nSession blogSessions}
-       return nSession
-
-getSession :: SessionID -> Query Blog (Maybe Session)
-getSession sId =
-  do Blog{..} <- ask
-     return $ getOne $ blogSessions @= sId
-
-clearSessions :: Update Blog [Session]
-clearSessions =
-  do b@Blog{..} <- get
-     put $ b { blogSessions = empty }
-     return []
-
-addUser :: Text -> String -> Update Blog User
-addUser un pw =
-    do b@Blog{..} <- get
-       let u = User un $ hashString pw
-       put $ b { blogUsers = IxSet.insert u blogUsers}
-       return u
-
-getUser :: Username -> Query Blog (Maybe User)
-getUser uN =
-  do Blog{..} <- ask
-     return $ getOne $ blogUsers @= uN
-
-checkUser :: Username -> String -> Query Blog Bool
-checkUser uN pw =
-  do Blog{..} <- ask
-     let user = getOne $ blogUsers @= uN
-     case user of
-       Nothing  -> return False
-       (Just u) -> return $ password u == hashString pw
-
--- various functions
-hashString :: String -> ByteString
-hashString = B64.encode .  SHA.hash . B.pack
-
-$(makeAcidic ''Blog
-    [ 'insertEntry
-    , 'updateEntry
-    , 'deleteEntry
-    , 'getEntry
-    , 'latestEntries
-    , 'addSession
-    , 'getSession
-    , 'addUser
-    , 'getUser
-    , 'checkUser
-    , 'clearSessions
-    ])
-
-interactiveUserAdd :: String -> IO ()
-interactiveUserAdd dbHost = do
-  acid <- openRemoteState skipAuthenticationPerform dbHost (PortNumber 8070)
-  putStrLn "Username:"
-  un <- getLine
-  putStrLn "Password:"
-  pw <- getLine
-  update' acid (AddUser (pack un) pw)
-  closeAcidState acid
-
-flushSessions :: IO ()
-flushSessions = do
-  tbDir <- getEnv "TAZBLOG"
-  acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
-  update' acid ClearSessions
-  closeAcidState acid
-
-archiveState :: IO ()
-archiveState = do
-    tbDir <- getEnv "TAZBLOG"
-    acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
-    createArchive acid
-    closeAcidState acid
diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs
new file mode 100644
index 000000000000..5ed67ac93864
--- /dev/null
+++ b/services/tazblog/src/BlogStore.hs
@@ -0,0 +1,54 @@
+-- |This module implements fetching of individual blog entries from
+-- DNS. Yes, you read that correctly.
+--
+-- Each blog post is stored as a set of records in a designated DNS
+-- zone. For the production blog, this zone is `blog.tazj.in.`.
+--
+-- A top-level record at `_posts` contains a list of all published
+-- post IDs.
+--
+-- For each of these post IDs, there is a record at `_meta.$postID`
+-- that contains the title and number of post chunks.
+--
+-- For each post chunk, there is a record at `_$chunkID.$postID` that
+-- contains a base64-encoded post fragment.
+--
+-- This module implements logic for assembling a post out of these
+-- fragments and caching it based on the TTL of its `_meta` record.
+
+module BlogStore where
+
+import           Data.Text              (Text)
+import Locales (BlogLang(..))
+import           Data.Time (UTCTime)
+import Control.Monad.IO.Class (MonadIO)
+
+newtype EntryId = EntryId { unEntryId :: Integer }
+    deriving (Eq, Ord)
+
+instance Show EntryId where
+  show = show . unEntryId
+
+data Entry = Entry {
+    entryId :: EntryId,
+    lang    :: BlogLang,
+    author  :: Text,
+    title   :: Text,
+    btext   :: Text,
+    mtext   :: Text,
+    edate   :: UTCTime
+} deriving (Eq, Ord, Show)
+
+data BlogCache
+
+type Offset = Integer
+type Count = Integer
+
+newCache :: String -> IO BlogCache
+newCache zone = undefined
+
+listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
+listEntries cache offset count = undefined
+
+getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
+getEntry cache eId = undefined
diff --git a/services/tazblog/src/Locales.hs b/services/tazblog/src/Locales.hs
index 125e99aef9c7..2e49809eee32 100644
--- a/services/tazblog/src/Locales.hs
+++ b/services/tazblog/src/Locales.hs
@@ -1,15 +1,21 @@
 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
 module Locales where
 
-import           BlogDB      (BlogLang (..))
 import           Data.Maybe  (fromMaybe)
 import           Data.Text   (Text)
 import qualified Data.Text   as T
 import           Network.URI
 
+data BlogLang = EN | DE
+    deriving (Eq, Ord)
+
+instance Show BlogLang where
+    show DE = "de"
+    show EN = "en"
+
 data BlogError = NotFound | UnknownError
 
-version = "5.1.2"
+version = "6.0.0"
 
 blogTitle :: BlogLang -> Text -> Text
 blogTitle DE s = T.concat ["Tazjins blog", s]
diff --git a/services/tazblog/src/RSS.hs b/services/tazblog/src/RSS.hs
index 1cfdc7111ef2..5d2340d5292f 100644
--- a/services/tazblog/src/RSS.hs
+++ b/services/tazblog/src/RSS.hs
@@ -9,7 +9,7 @@ import Data.Time     (UTCTime, getCurrentTime)
 import Network.URI
 import Text.RSS
 
-import BlogDB  hiding (Title)
+import BlogStore
 import Locales
 
 createChannel :: BlogLang -> UTCTime -> [ChannelElem]
diff --git a/services/tazblog/src/Server.hs b/services/tazblog/src/Server.hs
index fe26f9544252..57b1463268c2 100644
--- a/services/tazblog/src/Server.hs
+++ b/services/tazblog/src/Server.hs
@@ -2,20 +2,15 @@
 module Server where
 
 import           Control.Applicative    (optional)
-import           Control.Monad          (msum, mzero, unless)
+import Control.Monad (msum)
 import           Control.Monad.IO.Class (liftIO)
-import           Data.Acid
-import           Data.Acid.Advanced
-import           Data.ByteString.Char8  (unpack)
 import           Data.Char              (toLower)
-import           Data.Text              (Text)
 import qualified Data.Text              as T
-import           Data.Time
 import           Happstack.Server       hiding (Session)
-import Data.Maybe (fromJust)
+import Data.Maybe (maybe)
 
 import Blog
-import BlogDB  hiding (updateEntry)
+import BlogStore
 import Locales
 import RSS
 
@@ -26,32 +21,32 @@ instance FromReqURI BlogLang where
       "en" -> Just EN
       _    -> Nothing
 
+pageSize :: Integer
+pageSize = 3
+
 tmpPolicy :: BodyPolicy
 tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
 
-runBlog :: AcidState Blog -> Int -> String -> IO ()
-runBlog acid port respath =
-  simpleHTTP nullConf {port = port} $ tazBlog acid respath
+runBlog :: Int -> String -> IO ()
+runBlog port respath = do
+  cache <- newCache "blog.tazj.in."
+  simpleHTTP nullConf {port = port} $ tazBlog cache respath
 
-tazBlog :: AcidState Blog -> String -> ServerPart Response
-tazBlog acid resDir = do
-    msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
-         , dir "admin" $ msum [
-                adminHandler acid -- this checks auth
-              , method GET >> (ok $ toResponse adminLogin)
-              , method POST >> processLogin acid ]
+tazBlog :: BlogCache -> String -> ServerPart Response
+tazBlog cache resDir = do
+    msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang
          , dir "static" $ staticHandler resDir
-         , blogHandler acid EN
+         , blogHandler cache EN
          , staticHandler resDir
          , notFound $ toResponse $ showError NotFound DE
          ]
 
-blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
-blogHandler acid lang =
-    msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
-         , nullDir >> showIndex acid lang
-         , dir "rss" $ nullDir >> showRSS acid lang
-         , dir "rss.xml" $ nullDir >> showRSS acid lang
+blogHandler :: BlogCache -> BlogLang -> ServerPart Response
+blogHandler cache lang =
+    msum [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId
+         , nullDir >> showIndex cache lang
+         , dir "rss" $ nullDir >> showRSS cache lang
+         , dir "rss.xml" $ nullDir >> showRSS cache lang
          , notFound $ toResponse $ showError NotFound lang
          ]
 
@@ -61,20 +56,9 @@ staticHandler resDir = do
   setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
   serveDirectory DisableBrowsing [] resDir
 
-adminHandler :: AcidState Blog -> ServerPart Response
-adminHandler acid = do
-  guardSession acid
-  msum [ dir "entry" $ method POST >> postEntry acid
-       , dir "entry" $ path $ \(entry :: Integer) -> msum [
-              method GET >> editEntry acid entry
-            , method POST >> updateEntry acid entry ]
-       , dir "entrylist" $ path $ \(lang :: BlogLang) -> entryList acid lang
-       , ok $ toResponse $ adminIndex "tazjin"
-       ]
-
-showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
-showEntry acid lang eId = do
-    entry <- query' acid (GetEntry eId)
+showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
+showEntry cache lang eId = do
+    entry <- getEntry cache eId
     tryEntry entry lang
 
 tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
@@ -84,107 +68,19 @@ tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEn
         eTitle = T.append ": " (title entry)
         eLang = lang entry
 
-showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
-showIndex acid lang = do
-    entries <- query' acid (LatestEntries lang)
-    (page :: Maybe Int) <- optional $ lookRead "page"
+offset :: Maybe Integer -> Integer
+offset = maybe 0 ((*) pageSize)
+
+showIndex :: BlogCache -> BlogLang -> ServerPart Response
+showIndex cache lang = do
+    (page :: Maybe Integer) <- optional $ lookRead "page"
+    entries <- listEntries cache (offset page) pageSize
     ok $ toResponse $ blogTemplate lang "" $
-        renderEntries 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
+        renderEntries entries (Just $ showLinks page lang)
 
-showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
-showRSS acid lang = do
-    entries <- query' acid (LatestEntries lang)
-    feed <- liftIO $ renderFeed lang $ take 6 entries
+showRSS :: BlogCache -> BlogLang -> ServerPart Response
+showRSS cache lang = do
+    entries <- listEntries cache 0 4
+    feed <- liftIO $ renderFeed lang entries
     setHeaderM "content-type" "text/xml"
     ok $ toResponse feed
-
-{- ADMIN stuff -}
-
-postEntry :: AcidState Blog -> ServerPart Response
-postEntry acid = do
-    nullDir
-    decodeBody tmpPolicy
-    now <- liftIO getCurrentTime
-    let eId = timeToId now
-    lang <- look "lang"
-    nBtext <- lookText' "btext"
-    nMtext <- lookText' "mtext"
-    nEntry <- Entry <$> pure eId
-                    <*> getLang lang
-                    <*> readCookieValue "sUser"
-                    <*> lookText' "title"
-                    <*> pure nBtext
-                    <*> pure nMtext
-                    <*> pure now
-    update' acid (InsertEntry nEntry)
-    seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse())
-  where
-    timeToId :: UTCTime -> EntryId
-    timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
-    getLang :: String -> ServerPart BlogLang
-    getLang "de" = return DE
-    getLang _ = return EN -- English is default
-
-entryList :: AcidState Blog -> BlogLang -> ServerPart Response
-entryList acid lang = do
-    entries <- query' acid (LatestEntries lang)
-    ok $ toResponse $ adminEntryList entries
-
-editEntry :: AcidState Blog -> Integer -> ServerPart Response
-editEntry acid entryId = do
-    entry <- query' acid (GetEntry $ EntryId entryId)
-    ok $ toResponse $ editPage $ fromJust entry
-
-updateEntry :: AcidState Blog -> Integer -> ServerPart Response
-updateEntry acid entryId = do
-    decodeBody tmpPolicy
-    entry <- query' acid (GetEntry $ EntryId entryId)
-    nTitle <- lookText' "title"
-    nBtext <- lookText' "btext"
-    nMtext <- lookText' "mtext"
-    let newEntry = (fromJust entry)
-          { title = nTitle
-          , btext = nBtext
-          , mtext = nMtext}
-    update' acid (UpdateEntry newEntry)
-    seeOther (concat $ ["/", show $ lang newEntry, "/", show entryId])
-             (toResponse ())
-
-guardSession :: AcidState Blog -> ServerPartT IO ()
-guardSession acid = do
-    (sId :: Text) <- readCookieValue "session"
-    (uName :: Text) <- readCookieValue "sUser"
-    now <- liftIO getCurrentTime
-    mS <- query' acid (GetSession $ SessionID sId)
-    case mS of
-      Nothing -> mzero
-      (Just Session{..}) -> unless ((uName == username user) && sessionTimeDiff now sdate)
-                                   mzero
-  where
-    sessionTimeDiff :: UTCTime -> UTCTime -> Bool
-    sessionTimeDiff now sdate = diffUTCTime now sdate < 43200
-
-
-processLogin :: AcidState Blog -> ServerPart Response
-processLogin acid = do
-    decodeBody tmpPolicy
-    account <- lookText' "account"
-    password <- look "password"
-    login <- query' acid (CheckUser (Username account) password)
-    if login
-      then createSession account
-      else unauthorized $ toResponse adminLogin
-  where
-    createSession account = do
-      now <- liftIO getCurrentTime
-      let sId = hashString $ show now
-      addCookie (MaxAge 43200) (mkCookie "session" $ unpack sId)
-      addCookie (MaxAge 43200) (mkCookie "sUser" $ T.unpack account)
-      user <- query' acid (GetUser $ Username account)
-      let nSession = Session (T.pack $ unpack sId) (fromJust user) now
-      update' acid (AddSession nSession)
-      seeOther ("/admin?do=login" :: Text) (toResponse())
author	Vincent Ambo <tazjin@google.com>	2019-08-19T23·17+0100
committer	Vincent Ambo <tazjin@google.com>	2019-08-19T23·17+0100
commit	11fcf6229751eb266485cbba78d30aced1787d14 (patch)
tree	025f02ca1d1288949f69468e32d9efe795db02a7 /services/tazblog/src
parent	1d5b53abf8da7b00ac1e58d43a30f738c157b9d3 (diff)