diff options
Diffstat (limited to 'services/tazblog/src')
-rw-r--r-- | services/tazblog/src/Blog.hs | 110 | ||||
-rw-r--r-- | services/tazblog/src/BlogDB.hs | 241 | ||||
-rw-r--r-- | services/tazblog/src/BlogStore.hs | 54 | ||||
-rw-r--r-- | services/tazblog/src/Locales.hs | 10 | ||||
-rw-r--r-- | services/tazblog/src/RSS.hs | 2 | ||||
-rw-r--r-- | services/tazblog/src/Server.hs | 174 |
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()) |