* changed comment structure to sort by UTCTime

* postEntry function done; adminHandler doesn't work?

TODO

@@ -1,3 +1,3 @@
 * handle BlogErrors
-* fix sessions
+* add readMore link
-* add readMore link
+* Twitter: http://twitter.github.com/bootstrap/index.html

src/Blog.hs

@@ -155,8 +155,8 @@ showSiteNotice = H.docTypeHtml $ do
 
 {- Administration pages -}
 
-adminTemplate :: Html -> Text -> Html
+adminTemplate :: Text -> Html -> Html
-adminTemplate body title = H.docTypeHtml $ do
+adminTemplate title body = H.docTypeHtml $ do
     H.head $ do
         H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/admin.css" ! A.media "all"
         H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
@@ -165,7 +165,8 @@ adminTemplate body title = H.docTypeHtml $ do
         body
 
 adminLogin :: Html
-adminLogin = H.div ! A.class_ "loginBox" $ do
+adminLogin = adminTemplate "Login" $
+  H.div ! A.class_ "loginBox" $ do
     H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login"
     H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/dologin" ! A.method "post" $ do
         H.p $ "Account ID"
@@ -175,6 +176,26 @@ adminLogin = H.div ! A.class_ "loginBox" $ do
         H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "password"
         H.p $ H.input ! A.alt "Anmelden" ! A.type_ "image" ! A.src "/res/signin.gif"
 
+adminIndex :: Text -> Html
+adminIndex sUser = adminTemplate "Index" $
+  H.div ! A.style "float: center;" $
+    H.form ! A.action "/admin/postentry" ! A.method "POST" $ do
+      H.table $ do
+        H.tr $ do H.td $ "Titel:"
+                  H.td $ H.input ! A.type_ "text" ! A.name "title"
+        H.tr $ do H.td $ "Sprache:"
+                  H.td $ H.select ! A.name "lang" $ do
+                    H.option ! A.value "de" $ "Deutsch"
+                    H.option ! A.value "en" $ "Englisch"
+        H.tr $ do H.td ! A.style "vertical-align: top;" $ "Text:"
+                  H.td $ H.textarea ! A.name "btext" ! A.cols "100" ! A.rows "15" $ mempty
+        H.tr $ do H.td ! A.style "vertical-align: top;" $ "Mehr Text:"
+                  H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ mempty
+      H.input ! A.type_ "hidden" ! A.name "author" ! A.value (toValue sUser)
+      H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
+      H.p $ do preEscapedText "<a href=/>Startseite</a> -- Entrylist: <a href=/admin/entrylist/de>DE</a>"
+               preEscapedText " & <a href=/admin/entrylist/en>EN</a> -- <a href=#>Backup</a> (NYI)"
+
 -- Error pages
 showError :: BlogError -> BlogLang -> Html
 showError NotFound l = undefined

src/BlogDB.hs

@@ -40,10 +40,10 @@ instance Show BlogLang where
 
 $(deriveSafeCopy 0 'base ''BlogLang)
 
-data Comment = Comment { 
+data Comment = Comment {
+    cdate   :: UTCTime,
     cauthor :: Text,
-    ctext   :: Text,
+    ctext   :: Text
-    cdate   :: UTCTime
 } deriving (Eq, Ord, Show, Data, Typeable)
 
 $(deriveSafeCopy 0 'base ''Comment)
@@ -221,11 +221,18 @@ interactiveUserAdd = do
   putStrLn "Password:"
   pw <- getLine
   update' acid (AddUser (pack un) pw)
-  createCheckpointAndClose acid
+  closeAcidState acid
 
 flushSessions :: IO ()
 flushSessions = do
   tbDir <- getEnv "TAZBLOG"
   acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
   update' acid (ClearSessions)
-  createCheckpointAndClose acid
+  closeAcidState acid
+
+archiveState :: IO ()
+archiveState = do
+    tbDir <- getEnv "TAZBLOG"
+    acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
+    createArchive acid
+    closeAcidState acid

src/Main.hs

@@ -27,13 +27,13 @@ import           System.Environment(getEnv)
 import           System.Locale (defaultTimeLocale)
 
 import           Blog
-import           BlogDB hiding (addComment)
+import           BlogDB hiding (addComment, updateEntry)
 import           Locales
 
 {- Server -}
 
 tmpPolicy :: BodyPolicy
-tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
+tmpPolicy = (defaultBodyPolicy "./tmp/" 0 200000 1000)
 
 main :: IO()
 main = do
@@ -44,7 +44,7 @@ main = do
             (\acid -> simpleHTTP nullConf $ tazBlog acid)
 
 tazBlog :: AcidState Blog -> ServerPart Response
-tazBlog acid = do
+tazBlog acid =
     msum [ dir (show DE) $ blogHandler acid DE
          , dir (show EN) $ blogHandler acid EN
          , do nullDir
@@ -55,8 +55,8 @@ tazBlog acid = do
          , dir "res" $ serveDirectory DisableBrowsing [] "../res"
          , dir "notice" $ ok $ toResponse showSiteNotice
          , do dir "admin" $ guardSession acid
-              adminHandler
+              adminHandler acid
-         , dir "admin" $ ok $ toResponse $ adminTemplate adminLogin "Login"
+         , dir "admin" $ ok $ toResponse $ adminLogin 
          , dir "dologin" $ processLogin acid
          , serveDirectory DisableBrowsing [] "../res"
          ]
@@ -64,29 +64,13 @@ tazBlog acid = do
 blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
 blogHandler acid lang = 
     msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
-         , do
+         , do decodeBody tmpPolicy
-            decodeBody tmpPolicy
+              dir "postcomment" $ path $ 
-            dir "postcomment" $ path $ 
+                \(eId :: Integer) -> addComment acid lang $ EntryId eId
-              \(eId :: Integer) -> addComment acid $ EntryId eId
          , do nullDir
               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
-
 formatOldLink :: Int -> Int -> String -> ServerPart Response
 formatOldLink y m id_ = 
   flip seeOther (toResponse ()) $ 
@@ -115,14 +99,79 @@ showIndex acid lang = do
     eDrop (Just i) = drop ((i-1) * 6)
     eDrop Nothing = drop 0 
 
-addComment :: AcidState Blog -> EntryId -> ServerPart Response
+addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
-addComment acid eId = do
+addComment acid lang eId = do
   now <- liftIO $ getCurrentTime >>= return
-  nComment <- Comment <$> lookText' "cname"
+  nComment <- Comment <$> pure now
+                      <*> lookText' "cname"
                       <*> lookText' "ctext"
-                      <*> pure now
   update' acid (AddComment eId nComment)
-  seeOther ("/" ++ show eId) (toResponse())
+  seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
+
+{- ADMIN stuff -}
+
+adminHandler :: AcidState Blog -> ServerPart Response
+adminHandler acid = 
+  msum [ dir "postentry" $ postEntry acid
+       , dir "entrylist" $ dir (show DE) $ entryList DE
+       , dir "entrylist" $ dir (show EN) $ entryList EN
+       , dir "edit" $ path $ \(eId :: Integer) -> editEntry eId 
+       , dir "doedit" $ updateEntry 
+       , ok $ toResponse $ adminIndex ("tazjin" :: Text) --User NYI
+       ]
+
+updateEntry :: ServerPart Response
+updateEntry = undefined
+
+postEntry :: AcidState Blog -> ServerPart Response
+postEntry acid = do
+    liftIO $ putStrLn "postEntry called"
+    --decodeBody tmpPolicy
+    now <- liftIO $ getCurrentTime
+    let eId = timeToId now
+    lang <- lookText' "lang"
+    nEntry <- Entry <$> pure eId
+                    <*> getLang lang
+                    <*> lookText' "author"
+                    <*> lookText' "title"
+                    <*> lookText' "btext"
+                    <*> lookText' "mtext"
+                    <*> pure now
+                    <*> pure [] -- NYI
+                    <*> pure []
+    update' acid (InsertEntry nEntry)
+    seeOther ("/" ++ (T.unpack lang) ++ "/" ++ show eId) (toResponse())
+  where
+    timeToId :: UTCTime -> EntryId
+    timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
+    getLang :: Text -> ServerPart BlogLang
+    getLang "de" = return DE
+    getLang "en" = return EN
+
+
+entryList :: BlogLang -> ServerPart Response
+entryList lang = undefined
+
+editEntry :: Integer -> ServerPart Response
+editEntry i = undefined
+  where
+    eId = EntryId i
+
+guardSession :: AcidState Blog -> ServerPartT IO ()
+guardSession acid = do
+    (sId :: Text) <- readCookieValue "session"
+    (uName :: Text) <- readCookieValue "sUser"
+    now <- liftIO $ getCurrentTime
+    mS <- query' acid (GetSession $ SessionID sId)
+    case mS of
+      Nothing -> mzero
+      (Just Session{..}) -> unless (and [ uName == username user
+                                        , sessionTimeDiff now sdate])
+                                    mzero
+  where
+    sessionTimeDiff :: UTCTime -> UTCTime -> Bool
+    sessionTimeDiff now sdate = (diffUTCTime now sdate) < 43200
+
 
 processLogin :: AcidState Blog -> ServerPart Response
 processLogin acid = do
@@ -132,7 +181,7 @@ processLogin acid = do
     login <- query' acid (CheckUser (Username account) password)
     if' login
       (createSession account)
-      (ok $ toResponse $ adminTemplate adminLogin "Login failed")
+      (ok $ toResponse $ adminLogin)
   where
     createSession account = do
       now <- liftIO getCurrentTime

tools/acid-migrate/Acid.hs

@@ -54,10 +54,10 @@ instance Show BlogLang where
 
 $(deriveSafeCopy 0 'base ''BlogLang)
 
-data Comment = Comment { 
+data Comment = Comment {
+    cdate   :: UTCTime,
     cauthor :: Text,
-    ctext   :: Text,
+    ctext   :: Text
-    cdate   :: UTCTime
 } deriving (Eq, Ord, Show, Data, Typeable)
 
 $(deriveSafeCopy 0 'base ''Comment)
@@ -203,7 +203,7 @@ instance JSON Comment where
         jsscdate <- jsonField "cdate" obj :: Result JSValue
         let rcdate = stripResult $ jsonInt jsscdate
         sctext <- jsonField "ctext" obj
-        return $ Comment (pack scauthor) (pack sctext) (parseSeconds rcdate)
+        return $ Comment (parseSeconds rcdate) (pack scauthor) (pack sctext)
 
 instance JSON Entry where
     showJSON = undefined