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

1 files changed, 49 insertions, 201 deletions

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