* blog is now running off acid-state (this thing is *fast*)
This commit is contained in:
Vincent Ambo
parent
1c4db3b576
commit
6092eb6f5e
5 changed files with 286 additions and 261 deletions
70
src/Blog.hs
70
src/Blog.hs
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}
|
||||
|
||||
module Blog where
|
||||
|
||||
|
|
@ -16,34 +16,7 @@ import qualified Text.Blaze.Html5 as H
|
|||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
|
||||
import Locales
|
||||
|
||||
data Comment = Comment{
|
||||
cauthor :: String,
|
||||
ctext :: String,
|
||||
cdate :: Integer
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data Author = Author {
|
||||
username :: String,
|
||||
password :: String
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data Entry = Entry{
|
||||
_id :: String,
|
||||
year :: Int,
|
||||
month :: Int,
|
||||
day :: Int,
|
||||
lang :: BlogLang,
|
||||
title :: String,
|
||||
author :: String,
|
||||
text :: String,
|
||||
mtext :: String,
|
||||
comments :: [Comment]
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
blogText :: (a -> String) -> a -> Text
|
||||
blogText f = T.pack . f
|
||||
|
||||
import BlogDB
|
||||
|
||||
-- custom list functions
|
||||
intersperse' :: a -> [a] -> [a]
|
||||
|
|
@ -99,29 +72,29 @@ renderEntries showAll entries topText footerLinks =
|
|||
showEntry :: Entry -> Html
|
||||
showEntry e = H.li $ do
|
||||
entryLink e
|
||||
preEscapedText $ T.concat [" ", blogText text e, "<br> </br>"]
|
||||
preEscapedText $ T.concat [" ", btext e, "<br> </br>"]
|
||||
entryLink e = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $
|
||||
toHtml ("[" ++ show(length $ comments e) ++ "]")
|
||||
linkElems e = [show(lang e), show(year e), show(month e), show(day e), _id e]
|
||||
linkElems e = [show(lang e), show $ entryId e]
|
||||
getFooterLinks (Just h) = h
|
||||
getFooterLinks Nothing = mempty
|
||||
|
||||
renderEntry :: Entry -> Html
|
||||
renderEntry entry = H.div ! A.class_ "innerBox" $ do
|
||||
H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry
|
||||
renderEntry (Entry{..}) = H.div ! A.class_ "innerBox" $ do
|
||||
H.div ! A.class_ "innerBoxTop" $ toHtml $ title
|
||||
H.div ! A.class_ "innerBoxMiddle" $ do
|
||||
H.article $ H.ul $ H.li $ do
|
||||
preEscapedText $ blogText text entry
|
||||
preEscapedText $ blogText mtext entry
|
||||
preEscapedText $ btext
|
||||
preEscapedText $ mtext
|
||||
H.div ! A.class_ "innerBoxComments" $ do
|
||||
H.div ! A.class_ "cHead" $ toHtml $ cHead (lang entry) -- ! A.style "font-size:large;font-weight:bold;"
|
||||
H.ul $ renderComments (comments entry) (lang entry)
|
||||
renderCommentBox (lang entry) (_id entry)
|
||||
H.div ! A.class_ "cHead" $ toHtml $ cHead lang -- ! A.style "font-size:large;font-weight:bold;"
|
||||
H.ul $ renderComments comments lang
|
||||
renderCommentBox lang entryId
|
||||
|
||||
renderCommentBox :: BlogLang -> String -> Html
|
||||
renderCommentBox :: BlogLang -> EntryId -> Html
|
||||
renderCommentBox cLang cId = do
|
||||
H.div ! A.class_ "cHead" $ toHtml $ cwHead cLang
|
||||
H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++ "/postcomment/" ++ cId) $ do
|
||||
H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++ "/postcomment/" ++ show cId) $ do
|
||||
H.p $ H.label $ do
|
||||
H.span $ "Name:" --toHtml ("Name:" :: String)
|
||||
H.input ! A.name "cname"
|
||||
|
|
@ -135,16 +108,11 @@ renderComments [] lang = H.li $ toHtml $ noComments lang
|
|||
renderComments comments lang = sequence_ $ map showComment comments
|
||||
where
|
||||
showComment :: Comment -> Html
|
||||
showComment c = H.li $ do
|
||||
H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $
|
||||
H.i $ toHtml $ (cauthor c ++ ": ")
|
||||
preEscapedText $ blogText ctext c
|
||||
H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c)
|
||||
getTime :: Integer -> Maybe UTCTime
|
||||
getTime t = parseTime defaultTimeLocale "%s" (show t)
|
||||
showTime lang (Just t) = formatTime defaultTimeLocale (cTimeFormat lang) t
|
||||
showTime _ Nothing = "[???]" -- this can not happen??
|
||||
timeString = (showTime lang) . getTime
|
||||
showComment (Comment{..}) = H.li $ do
|
||||
H.i $ toHtml $ T.append cauthor ": "
|
||||
preEscapedText $ ctext
|
||||
H.p ! A.class_ "tt" $ toHtml $ timeString cdate
|
||||
timeString t = formatTime defaultTimeLocale (cTimeFormat lang) t
|
||||
|
||||
showLinks :: Maybe Int -> BlogLang -> Html
|
||||
showLinks (Just i) lang
|
||||
|
|
@ -161,7 +129,7 @@ showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
|
|||
toHtml ("Proudly made with " :: Text)
|
||||
H.a ! A.href "http://haskell.org" $ "Haskell"
|
||||
toHtml (", " :: Text)
|
||||
H.a ! A.href "http://couchdb.apache.org/" $ "CouchDB"
|
||||
H.a ! A.href "http://hackage.haskell.org/package/acid-state-0.6.3" $ "Acid-State"
|
||||
toHtml (" and without PHP, Java, Perl, MySQL and Python." :: Text)
|
||||
H.br
|
||||
H.a ! A.href (toValue repoURL) $ toHtml $ T.append "Version " v
|
||||
|
|
|
|||
208
src/BlogDB.hs
Normal file
208
src/BlogDB.hs
Normal file
|
|
@ -0,0 +1,208 @@
|
|||
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards,
|
||||
TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
|
||||
|
||||
module BlogDB where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (get, put)
|
||||
import Data.Acid
|
||||
import Data.Acid.Advanced
|
||||
import Data.Acid.Local
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Data (Data, Typeable)
|
||||
import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet)
|
||||
import Data.List (insert)
|
||||
import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Time
|
||||
import Happstack.Server (ServerPart)
|
||||
|
||||
import qualified Crypto.Hash.SHA512 as SHA (hash)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Base64 as B64 (encode)
|
||||
import qualified Data.IxSet as IxSet
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
newtype EntryId = EntryId { unEntryId :: Integer }
|
||||
deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy)
|
||||
|
||||
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 Comment = Comment {
|
||||
cauthor :: Text,
|
||||
ctext :: Text,
|
||||
cdate :: UTCTime
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Comment)
|
||||
|
||||
data Entry = Entry {
|
||||
entryId :: EntryId,
|
||||
lang :: BlogLang,
|
||||
author :: Text,
|
||||
title :: Text,
|
||||
btext :: Text,
|
||||
mtext :: Text,
|
||||
edate :: UTCTime,
|
||||
tags :: [Text],
|
||||
comments :: [Comment]
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Entry)
|
||||
|
||||
-- ixSet requires different datatypes for field indexes, so let's define some
|
||||
newtype Author = Author Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype Title = Title Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype BText = BText Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -- standard text
|
||||
newtype MText = MText Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -- "read more" text
|
||||
newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype EDate = EDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype Username = Username Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
|
||||
|
||||
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]
|
||||
, ixFun $ \e -> map Tag (tags e)
|
||||
, ixFun $ comments
|
||||
]
|
||||
|
||||
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
|
||||
|
||||
addComment :: EntryId -> Comment -> Update Blog Entry
|
||||
addComment eId c =
|
||||
do b@Blog{..} <- get
|
||||
let (Just e) = getOne $ blogEntries @= eId
|
||||
let newEntry = e { comments = insert c $ comments e }
|
||||
put $ b { blogEntries = IxSet.updateIx eId newEntry blogEntries }
|
||||
return newEntry
|
||||
|
||||
updateEntry :: Entry -> Update Blog Entry
|
||||
updateEntry e =
|
||||
do b@Blog{..} <- get
|
||||
put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries}
|
||||
return e
|
||||
|
||||
getEntry :: EntryId -> Query Blog (Maybe Entry)
|
||||
getEntry eId =
|
||||
do b@Blog{..} <- ask
|
||||
return $ getOne $ blogEntries @= eId
|
||||
|
||||
latestEntries :: BlogLang -> Query Blog [Entry]
|
||||
latestEntries lang =
|
||||
do b@Blog{..} <- ask
|
||||
return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang
|
||||
|
||||
addSession :: Text -> User -> UTCTime -> Update Blog Session
|
||||
addSession sId u t =
|
||||
do b@Blog{..} <- get
|
||||
let s = Session sId u t
|
||||
put $ b { blogSessions = IxSet.insert s blogSessions}
|
||||
return s
|
||||
|
||||
getSession :: SessionID -> Query Blog (Maybe Session)
|
||||
getSession sId =
|
||||
do b@Blog{..} <- ask
|
||||
return $ getOne $ blogSessions @= sId
|
||||
|
||||
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 b@Blog{..} <- ask
|
||||
return $ getOne $ blogUsers @= uN
|
||||
|
||||
checkUser :: Username -> String -> Query Blog (Bool)
|
||||
checkUser uN pw =
|
||||
do b@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
|
||||
, 'addComment
|
||||
, 'updateEntry
|
||||
, 'getEntry
|
||||
, 'latestEntries
|
||||
, 'addSession
|
||||
, 'getSession
|
||||
, 'addUser
|
||||
, 'getUser
|
||||
, 'checkUser
|
||||
])
|
||||
|
||||
|
|
@ -6,18 +6,13 @@ import Data.Data (Data, Typeable)
|
|||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import BlogDB (BlogLang (..))
|
||||
|
||||
{- to add a language simply define its abbreviation and Show instance then
|
||||
- translate the appropriate strings and add CouchDB views in Server.hs -}
|
||||
|
||||
data BlogLang = EN | DE deriving (Data, Typeable)
|
||||
|
||||
instance Show BlogLang where
|
||||
show EN = "en"
|
||||
show DE = "de"
|
||||
|
||||
data BlogError = NotFound | DBError
|
||||
|
||||
|
||||
version = "2.2b"
|
||||
|
||||
allLang = [EN, DE]
|
||||
|
|
@ -77,6 +72,10 @@ nextText :: BlogLang -> Text
|
|||
nextText DE = "Später"
|
||||
nextText EN = "Later"
|
||||
|
||||
readMore :: BlogLang -> Text
|
||||
readMore DE = "[Weiterlesen]"
|
||||
readMore EN = "[Read more]"
|
||||
|
||||
-- contact information
|
||||
contactText :: BlogLang -> Text
|
||||
contactText DE = "Wer mich kontaktieren will: "
|
||||
|
|
|
|||
250
src/Main.hs
250
src/Main.hs
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving,
|
||||
DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell,
|
||||
TypeFamilies, RecordWildCards #-}
|
||||
TypeFamilies, RecordWildCards, BangPatterns #-}
|
||||
|
||||
module Main where
|
||||
|
||||
|
|
@ -21,51 +21,15 @@ import Data.Text (Text)
|
|||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Database.CouchDB
|
||||
import Happstack.Server
|
||||
import Happstack.Server hiding (Session)
|
||||
import Network.CGI (liftIO)
|
||||
import Text.JSON.Generic
|
||||
import System.Environment(getEnv)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
|
||||
import Blog
|
||||
import BlogDB hiding (addComment)
|
||||
import Locales
|
||||
|
||||
data SessionState = SessionState { sessions :: [(String, Integer)] } -- id/date
|
||||
deriving (Eq, Ord, Read, Show, Data, Typeable)
|
||||
|
||||
initialSession :: SessionState
|
||||
initialSession = SessionState []
|
||||
|
||||
$(deriveSafeCopy 0 'base ''SessionState)
|
||||
|
||||
|
||||
data AccountState = AccountState { accounts :: [Account] }
|
||||
deriving (Read, Show, Data, Typeable)
|
||||
|
||||
data Account = Account { account :: String
|
||||
, password :: ByteString
|
||||
} deriving (Read, Show, Data, Typeable)
|
||||
|
||||
{-session handling functions-}
|
||||
|
||||
addSession :: (String, Integer) -> Update SessionState [(String, Integer)]
|
||||
addSession newS = do
|
||||
s@SessionState{..} <- get
|
||||
let newSessions = newS : sessions
|
||||
put $ s{ sessions = newSessions }
|
||||
return newSessions
|
||||
|
||||
querySessions :: Query SessionState [(String, Integer)]
|
||||
querySessions = sessions <$> ask
|
||||
|
||||
$(makeAcidic ''SessionState ['addSession, 'querySessions])
|
||||
$(makeAcidic ''AccountState [])
|
||||
{- various functions -}
|
||||
|
||||
hashString :: String -> ByteString
|
||||
hashString = B64.encode . SHA.hash . pack
|
||||
|
||||
{- Server -}
|
||||
|
||||
tmpPolicy :: BodyPolicy
|
||||
|
|
@ -75,48 +39,18 @@ main :: IO()
|
|||
main = do
|
||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||
tbDir <- getEnv "TAZBLOG"
|
||||
bracket (openLocalStateFrom (tbDir ++ "/State/SessionState") initialAccounts)
|
||||
bracket (openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState)
|
||||
(createCheckpointAndClose)
|
||||
(\sessionAcid -> bracket (openLocalStateFrom (tbDir ++ "/State/AccountState") )
|
||||
(createCheckpointAndClose)
|
||||
(\accountAcid -> simpleHTTP nullConf $
|
||||
tazBlog sessionAcid accountAcid))
|
||||
(\acid -> simpleHTTP nullConf $ tazBlog acid)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
initialAccounts :: AccountState
|
||||
initialAccounts = []
|
||||
|
||||
askAccount :: IO Account
|
||||
askAccount = do
|
||||
putStrLn "Enter name for the account:"
|
||||
n <- getLine
|
||||
putStrLn "Enter password for the account:"
|
||||
p <- getLine
|
||||
return $ Account n $ hashString p
|
||||
|
||||
guardSession :: AcidState SessionState -> ServerPartT IO ()
|
||||
guardSession acid = do
|
||||
sID <- lookCookieValue "session"
|
||||
sDate <- readCookieValue "sdate"
|
||||
cSessions <- query' acid QuerySessions
|
||||
cDate <- liftIO $ currentSeconds
|
||||
when (not $ elem (sID, sDate) cSessions)
|
||||
mzero
|
||||
when (32400 > (cDate - sDate))
|
||||
mzero
|
||||
|
||||
tazBlog :: AcidState SessionState -> ServerPart Response
|
||||
tazBlog :: AcidState Blog -> ServerPart Response
|
||||
tazBlog acid = do
|
||||
msum [ dir (show DE) $ blogHandler DE
|
||||
, dir (show EN) $ blogHandler EN
|
||||
msum [ dir (show DE) $ blogHandler acid DE
|
||||
, dir (show EN) $ blogHandler acid EN
|
||||
, do nullDir
|
||||
showIndex DE
|
||||
showIndex acid DE
|
||||
, do dir " " $ nullDir
|
||||
seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ())
|
||||
, path $ \(id_ :: Int) -> getEntryLink id_
|
||||
, path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
|
||||
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
|
||||
, dir "notice" $ ok $ toResponse showSiteNotice
|
||||
|
|
@ -127,18 +61,29 @@ tazBlog acid = do
|
|||
, serveDirectory DisableBrowsing [] "../res"
|
||||
]
|
||||
|
||||
blogHandler :: BlogLang -> ServerPart Response
|
||||
blogHandler lang =
|
||||
msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry
|
||||
\(day :: Int) -> path $ \(id_ :: String) -> showEntry lang id_
|
||||
, path $ \(year :: Int ) -> path $ \(month :: Int) -> showMonth year month lang
|
||||
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
||||
blogHandler acid lang =
|
||||
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
||||
, do
|
||||
decodeBody tmpPolicy
|
||||
dir "postcomment" $ path $ \(id_ :: String) -> addComment id_
|
||||
dir "postcomment" $ path $
|
||||
\(eId :: Integer) -> addComment acid $ EntryId eId
|
||||
, do nullDir
|
||||
showIndex lang
|
||||
showIndex acid lang
|
||||
]
|
||||
|
||||
guardSession :: AcidState Blog -> ServerPartT IO ()
|
||||
guardSession acid = do
|
||||
(sId :: Text) <- readCookieValue "session"
|
||||
(Just Session{..}) <- query' acid (GetSession $ SessionID sId)
|
||||
(uName :: Text) <- readCookieValue "sUser"
|
||||
now <- liftIO $ getCurrentTime
|
||||
unless (and [uName == username user, sessionTimeDiff now sdate])
|
||||
mzero
|
||||
where
|
||||
sessionTimeDiff :: UTCTime -> UTCTime -> Bool
|
||||
sessionTimeDiff now sdate = (diffUTCTime now sdate) > 43200
|
||||
|
||||
adminHandler :: ServerPart Response
|
||||
adminHandler = undefined
|
||||
|
||||
|
|
@ -147,32 +92,21 @@ formatOldLink y m id_ =
|
|||
flip seeOther (toResponse ()) $
|
||||
concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_]
|
||||
|
||||
showEntry :: BlogLang -> String -> ServerPart Response
|
||||
showEntry lang id_ = do
|
||||
entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc id_)
|
||||
let entry = maybeDoc entryJS
|
||||
showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
||||
showEntry acid lang eId = do
|
||||
entry <- query' acid (GetEntry eId)
|
||||
ok $ tryEntry entry lang
|
||||
|
||||
tryEntry :: Maybe Entry -> BlogLang -> Response
|
||||
tryEntry Nothing lang = toResponse $ showError NotFound lang
|
||||
tryEntry (Just entry) _ = toResponse $ blogTemplate eLang eTitle $ renderEntry entry
|
||||
where
|
||||
eTitle = T.pack $ ": " ++ title entry
|
||||
eTitle = T.append ": " (title entry)
|
||||
eLang = lang entry
|
||||
|
||||
getEntryLink :: Int -> ServerPart Response
|
||||
getEntryLink id_ = do
|
||||
entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc $ show id_)
|
||||
let entry = maybeDoc entryJS
|
||||
seeOther (makeLink entry) (toResponse())
|
||||
where
|
||||
makeLink :: Maybe Entry -> String
|
||||
makeLink (Just e) = concat $ intersperse' "/" [show $ lang e, show $ year e, show $ month e, show $ day e, show id_]
|
||||
makeLink Nothing = "/"
|
||||
|
||||
showIndex :: BlogLang -> ServerPart Response
|
||||
showIndex lang = do
|
||||
entries <- getLatest lang [("descending", showJSON True)]
|
||||
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) (topText lang) (Just $ showLinks page lang)
|
||||
|
|
@ -180,110 +114,24 @@ showIndex lang = do
|
|||
eDrop :: Maybe Int -> [a] -> [a]
|
||||
eDrop (Just i) = drop ((i-1) * 6)
|
||||
eDrop Nothing = drop 0
|
||||
|
||||
showMonth :: Int -> Int -> BlogLang -> ServerPart Response
|
||||
showMonth y m lang = do
|
||||
entries <- getLatest lang $ ("descending", showJSON True) : makeQuery startkey endkey
|
||||
ok $ toResponse $ blogTemplate lang month
|
||||
$ renderEntries True entries month Nothing
|
||||
where
|
||||
month = getMonth lang y m
|
||||
startkey = JSArray [toJSON y, toJSON m]
|
||||
endkey = JSArray [toJSON y, toJSON m, JSObject (toJSObject [] )]
|
||||
|
||||
addComment :: String -> ServerPart Response
|
||||
addComment id_ = do
|
||||
rda <- liftIO $ currentSeconds >>= return
|
||||
nComment <- Comment <$> look "cname"
|
||||
<*> look "ctext"
|
||||
<*> pure rda
|
||||
rev <- updateDBDoc (doc id_) $ insertComment nComment
|
||||
liftIO $ putStrLn $ show rev
|
||||
seeOther ("/" ++ id_) (toResponse())
|
||||
addComment :: AcidState Blog -> EntryId -> ServerPart Response
|
||||
addComment acid eId = do
|
||||
now <- liftIO $ getCurrentTime >>= return
|
||||
nComment <- Comment <$> lookText' "cname"
|
||||
<*> lookText' "ctext"
|
||||
<*> pure now
|
||||
update' acid (AddComment eId nComment)
|
||||
seeOther ("/" ++ show eId) (toResponse())
|
||||
|
||||
processLogin :: AcidState SessionState -> ServerPart Response
|
||||
processLogin :: AcidState Blog -> ServerPart Response
|
||||
processLogin acid = do
|
||||
decodeBody tmpPolicy
|
||||
account <- look "account"
|
||||
account <- lookText' "account"
|
||||
password <- look "password"
|
||||
ok $ toResponse ("Shut up" :: String)
|
||||
|
||||
|
||||
-- http://tazj.in/2012/02/10.155234
|
||||
|
||||
currentSeconds :: IO Integer
|
||||
currentSeconds = do
|
||||
now <- getCurrentTime
|
||||
let s = read (formatTime defaultTimeLocale "%s" now) :: Integer
|
||||
return s
|
||||
|
||||
{- CouchDB functions -}
|
||||
|
||||
getLatest :: BlogLang -> [(String, JSValue)] -> ServerPart [Entry]
|
||||
getLatest lang arg = do
|
||||
queryResult <- queryDB view arg
|
||||
let entries = map (stripResult . fromJSON . snd) queryResult
|
||||
return entries
|
||||
where
|
||||
view = case lang of
|
||||
EN -> "latestEN"
|
||||
DE -> "latestDE"
|
||||
|
||||
insertComment :: Comment -> JSValue -> IO JSValue
|
||||
insertComment c jEntry = return $ toJSON $ e { comments = c : (comments e)}
|
||||
login <- query' acid (CheckUser (Username account) password)
|
||||
if' login
|
||||
(addSessionCookie account)
|
||||
(ok $ toResponse $ ("Fail?" :: Text))
|
||||
where
|
||||
e = convertJSON jEntry :: Entry
|
||||
|
||||
makeQuery :: JSON a => a -> a -> [(String, JSValue)]
|
||||
makeQuery qsk qek = [("startkey", (showJSON qsk))
|
||||
,("endkey", (showJSON qek))]
|
||||
|
||||
queryDB :: JSON a => String -> [(String, JSValue)] -> ServerPart [(Doc, a)]
|
||||
queryDB view arg = liftIO . runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc view) arg
|
||||
|
||||
maybeDoc :: Data a => Maybe (Doc, Rev, JSValue) -> Maybe a
|
||||
maybeDoc (Just(_,_,v)) = Just( stripResult $ fromJSON v)
|
||||
maybeDoc Nothing = Nothing
|
||||
|
||||
updateDBDoc :: JSON a => Doc -> (a -> IO a) -> ServerPart (Maybe Rev)
|
||||
updateDBDoc docn f = liftIO $ runCouchDB' $ getAndUpdateDoc (db "tazblog") docn f
|
||||
|
||||
stripResult :: Result a -> a
|
||||
stripResult (Ok z) = z
|
||||
stripResult (Error s) = error $ "JSON error: " ++ s
|
||||
|
||||
convertJSON :: Data a => JSValue -> a
|
||||
convertJSON = stripResult . fromJSON
|
||||
|
||||
getMonthCount :: BlogLang -> Int -> Int -> ServerPart Int
|
||||
getMonthCount lang y m = do
|
||||
count <- queryDB (view lang) $ makeQuery startkey endkey
|
||||
return . stripCount $ map (stripResult . fromJSON . snd) count
|
||||
where
|
||||
startkey = JSArray [toJSON ("count" :: String), toJSON y, toJSON m]
|
||||
endkey = JSArray [toJSON ("count" :: String), toJSON y, toJSON m, JSObject (toJSObject [] )]
|
||||
stripCount :: [Int] -> Int
|
||||
stripCount [x] = x
|
||||
stripCount [] = 0
|
||||
view DE = "countDE"
|
||||
view EN = "countEN"
|
||||
|
||||
|
||||
{- CouchDB View Setup -}
|
||||
latestDEView = "function(doc){ if(doc.lang == 'DE'){ emit([doc.year, doc.month, doc.day, doc._id], doc); } }"
|
||||
latestENView = "function(doc){ if(doc.lang == 'EN'){ emit([doc.year, doc.month, doc.day, doc._id], doc); } }"
|
||||
countDEView = "function(doc){ if(doc.lang == 'DE'){ emit(['count', doc.year, doc.month, doc.day, doc._id], 1); } }"
|
||||
countENView = "function(doc){ if(doc.lang == 'EN'){ emit(['count', doc.year, doc.month, doc.day, doc._id], 1); } }"
|
||||
countReduce = "function(keys, values, rereduce) { return sum(values); }"
|
||||
|
||||
latestDE = ViewMap "latestDE" latestDEView
|
||||
latestEN = ViewMap "latestEN" latestENView
|
||||
countDE = ViewMapReduce "countDE" countDEView countReduce
|
||||
countEN = ViewMapReduce "countEN" countENView countReduce
|
||||
|
||||
setupBlogViews :: IO ()
|
||||
setupBlogViews = runCouchDB' $
|
||||
newView "tazblog" "entries" [latestDE, latestEN, countDE, countEN]
|
||||
|
||||
|
||||
|
||||
addSessionCookie = undefined
|
||||
|
|
@ -19,7 +19,8 @@ import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
|
|||
import Data.Text (Text, pack)
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Time
|
||||
import Happstack.Server hiding (Session)
|
||||
import System.Environment(getEnv)
|
||||
|
||||
|
||||
import qualified Crypto.Hash.SHA512 as SHA (hash)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
|
|
@ -256,7 +257,8 @@ pasteToDB acid !e = update' acid (InsertEntry e)
|
|||
|
||||
main :: IO()
|
||||
main = do
|
||||
bracket (openLocalState initialBlogState)
|
||||
tbDir <- getEnv "TAZBLOG"
|
||||
bracket (openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState)
|
||||
(createCheckpointAndClose)
|
||||
(\acid -> convertEntries acid)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue