diff options
| -rw-r--r-- | TODO | 4 | ||||
| -rw-r--r-- | src/Blog.hs | 27 | ||||
| -rw-r--r-- | src/BlogDB.hs | 17 | ||||
| -rw-r--r-- | src/Main.hs | 109 | ||||
| -rw-r--r-- | tools/acid-migrate/Acid.hs | 8 |
5 files changed, 121 insertions, 44 deletions
diff --git a/TODO b/TODO index 7b2c54f446c6..3de1a19190d3 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 da8dd24dc62f..8e4c76b621e1 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 "<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 diff --git a/src/BlogDB.hs b/src/BlogDB.hs index d5a964da8a5a..7a4f869eb71b 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 b979c3bb8ab5..43faeac93f5c 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 276102eb030b..10ab3e23d0a0 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 |