diff --git a/TODO b/TODO
index 7b2c54f44..3de1a1919 100644
--- a/TODO
+++ b/TODO
@@ -1,3 +1,3 @@
* handle BlogErrors
-* fix sessions
-* add readMore link
\ No newline at end of file
+* add readMore link
+* Twitter: http://twitter.github.com/bootstrap/index.html
\ No newline at end of file
diff --git a/src/Blog.hs b/src/Blog.hs
index da8dd24dc..8e4c76b62 100644
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -155,8 +155,8 @@ showSiteNotice = H.docTypeHtml $ do
{- Administration pages -}
-adminTemplate :: Html -> Text -> Html
-adminTemplate body title = H.docTypeHtml $ do
+adminTemplate :: Text -> Html -> Html
+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 "Startseite -- Entrylist: DE"
+ preEscapedText " & EN -- Backup (NYI)"
+
-- Error pages
showError :: BlogError -> BlogLang -> Html
showError NotFound l = undefined
diff --git a/src/BlogDB.hs b/src/BlogDB.hs
index d5a964da8..7a4f869eb 100644
--- a/src/BlogDB.hs
+++ b/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,
- cdate :: UTCTime
+ ctext :: Text
} 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
diff --git a/src/Main.hs b/src/Main.hs
index b979c3bb8..43faeac93 100644
--- a/src/Main.hs
+++ b/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
- , dir "admin" $ ok $ toResponse $ adminTemplate adminLogin "Login"
+ adminHandler acid
+ , 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
- decodeBody tmpPolicy
- dir "postcomment" $ path $
- \(eId :: Integer) -> addComment acid $ EntryId eId
+ , do decodeBody tmpPolicy
+ dir "postcomment" $ path $
+ \(eId :: Integer) -> addComment acid lang $ 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 acid eId = do
+addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
+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
diff --git a/tools/acid-migrate/Acid.hs b/tools/acid-migrate/Acid.hs
index 276102eb0..10ab3e23d 100644
--- a/tools/acid-migrate/Acid.hs
+++ b/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,
- cdate :: UTCTime
+ ctext :: Text
} 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