diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blog.hs | 70 | ||||
| -rw-r--r-- | src/BlogDB.hs | 208 | ||||
| -rw-r--r-- | src/Locales.hs | 13 | ||||
| -rw-r--r-- | src/Main.hs | 250 |
4 files changed, 282 insertions, 259 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index aa1882073e5f..5f95d70058e0 100644 --- a/src/Blog.hs +++ b/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 diff --git a/src/BlogDB.hs b/src/BlogDB.hs new file mode 100644 index 000000000000..cade9327e7f1 --- /dev/null +++ b/src/BlogDB.hs @@ -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 + ]) + diff --git a/src/Locales.hs b/src/Locales.hs index 56bc42d10ba5..393a69f8fc18 100644 --- a/src/Locales.hs +++ b/src/Locales.hs @@ -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: " diff --git a/src/Main.hs b/src/Main.hs index 7990b8811ac2..58de3221837e 100644 --- a/src/Main.hs +++ b/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)} - 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 + login <- query' acid (CheckUser (Username account) password) + if' login + (addSessionCookie account) + (ok $ toResponse $ ("Fail?" :: Text)) 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 \ No newline at end of file |