* blog is now running off acid-state (this thing is *fast*)

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
-
+import           BlogDB
-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
-
 
 -- 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>&nbsp;</br>"]
+            preEscapedText $ T.concat [" ", btext e, "<br>&nbsp;</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
+renderEntry (Entry{..}) = H.div ! A.class_ "innerBox" $ do
-    H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry
+    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 $ btext
-            preEscapedText $ blogText mtext entry
+            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.div ! A.class_ "cHead" $ toHtml $ cHead lang -- ! A.style "font-size:large;font-weight:bold;"
-            H.ul $ renderComments (comments entry) (lang entry)
+            H.ul $ renderComments comments lang
-            renderCommentBox (lang entry) (_id entry)
+            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
+        showComment (Comment{..}) = H.li $ do
-            H.a ! A.name (toValue $ cdate c) ! A.href (toValue $ "#" ++ (show $ cdate c)) ! A.class_ "cl" $
+            H.i $ toHtml $ T.append cauthor ": "
-               H.i $ toHtml $ (cauthor c ++ ": ")
+            preEscapedText $ ctext
-            preEscapedText $ blogText ctext c
+            H.p ! A.class_ "tt" $ toHtml $ timeString cdate
-            H.p ! A.class_ "tt" $ toHtml (timeString $ cdate c)
+        timeString t = formatTime defaultTimeLocale (cTimeFormat lang) t
-        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
 
 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

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
+    ])
+

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: "

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 hiding (Session)
-import           Happstack.Server
 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") )
+            (\acid -> simpleHTTP nullConf $ tazBlog acid)
-                              (createCheckpointAndClose)
-                              (\accountAcid -> simpleHTTP nullConf $ 
-                                tazBlog sessionAcid accountAcid))
 
-
+tazBlog :: AcidState Blog -> ServerPart Response
-
-              
-
-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 acid = do
-    msum [ dir (show DE) $ blogHandler DE
+    msum [ dir (show DE) $ blogHandler acid DE
-         , dir (show EN) $ blogHandler EN
+         , 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 :: AcidState Blog -> BlogLang -> ServerPart Response
-blogHandler lang = 
+blogHandler acid lang = 
-    msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry
+    msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
-                      \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang id_
-         , path $ \(year :: Int ) -> path $ \(month :: Int) -> showMonth year month lang
          , 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 :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
-showEntry lang id_ = do
+showEntry acid lang eId = do
-    entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc id_)
+    entry <- query' acid (GetEntry eId)
-    let entry = maybeDoc entryJS
     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
+showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
-getEntryLink id_ = do
+showIndex acid lang = do
-    entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc $ show id_)
+    entries <- query' acid (LatestEntries lang)
-    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)]
     (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 :: AcidState Blog -> EntryId -> ServerPart Response
-addComment id_ = do
+addComment acid eId = do
-  rda <- liftIO $ currentSeconds >>= return
+  now <- liftIO $ getCurrentTime >>= return
-  nComment <- Comment <$> look "cname"
+  nComment <- Comment <$> lookText' "cname"
-                      <*> look "ctext"
+                      <*> lookText' "ctext"
-                      <*> pure rda
+                      <*> pure now
-  rev <- updateDBDoc (doc id_) $ insertComment nComment
+  update' acid (AddComment eId nComment)
-  liftIO $ putStrLn $ show rev
+  seeOther ("/" ++ show eId) (toResponse())
-  seeOther ("/" ++ id_) (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)
+    login <- query' acid (CheckUser (Username account) password)
-
+    if' login
-
+      (addSessionCookie account)
--- http://tazj.in/2012/02/10.155234
+      (ok $ toResponse $ ("Fail?" :: Text))
-
-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
+    addSessionCookie = undefined
-
-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]
-
-
-

tools/acid-migrate/Acid.hs

@@ -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)