diff options
Diffstat (limited to 'services/tazblog/src')
| -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 |
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()) |