* changed comment structure to sort by UTCTime
* postEntry function done; adminHandler doesn't work?
This commit is contained in:
Vincent Ambo
parent
f6446aec72
commit
e6746984f5
5 changed files with 121 additions and 44 deletions
2
TODO
2
TODO
|
|
@ -1,3 +1,3 @@
|
|||
* handle BlogErrors
|
||||
* fix sessions
|
||||
* add readMore link
|
||||
* Twitter: http://twitter.github.com/bootstrap/index.html
|
||||
27
src/Blog.hs
27
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
107
src/Main.hs
107
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
|
||||
, do decodeBody tmpPolicy
|
||||
dir "postcomment" $ path $
|
||||
\(eId :: Integer) -> addComment acid $ EntryId eId
|
||||
\(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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue