* 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
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
|
||||
Loading…
Add table
Add a link
Reference in a new issue