diff options
author | "Vincent Ambo ext:(%22) <tazjin@gmail.com> | 2013-04-28T12·44+0200 |
---|---|---|
committer | "Vincent Ambo ext:(%22) <tazjin@gmail.com> | 2013-04-28T12·44+0200 |
commit | c5206173e6445507f8468457ac5534065e8b9909 (patch) | |
tree | 6bb9cc9f00b04c0037eb984208b108804bdfdb93 /src | |
parent | 9719b5a62de0795a5cb62778de06c3aa7f206e95 (diff) |
ran hlint
Diffstat (limited to 'src')
-rw-r--r-- | src/Blog.hs | 2 | ||||
-rw-r--r-- | src/BlogDB.hs | 8 | ||||
-rw-r--r-- | src/Main.hs | 43 | ||||
-rw-r--r-- | src/RSS.hs | 13 |
4 files changed, 33 insertions, 33 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 2c1a546a2a57..e999d18fad10 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -163,7 +163,7 @@ renderEntry e@Entry{..} = [shamlet| ^{renderCommentBox lang entryId} |] where - woText = flip T.append author $ T.pack $ (formatTime defaultTimeLocale (eTimeFormat lang) edate) + woText = flip T.append author $ T.pack $ formatTime defaultTimeLocale (eTimeFormat lang) edate renderComments :: [Comment] -> BlogLang -> Html renderComments [] lang = [shamlet|<li>#{noComments lang}|] diff --git a/src/BlogDB.hs b/src/BlogDB.hs index b2551ecc3d99..c054d7f17dd2 100644 --- a/src/BlogDB.hs +++ b/src/BlogDB.hs @@ -97,7 +97,7 @@ instance Indexable Entry where , ixFun $ \e -> [ MText $ mtext e] , ixFun $ \e -> [ EDate $ edate e] , ixFun $ \e -> map Tag (tags e) - , ixFun $ comments + , ixFun comments ] data User = User { @@ -209,13 +209,13 @@ getUser uN = do b@Blog{..} <- ask return $ getOne $ blogUsers @= uN -checkUser :: Username -> String -> Query Blog (Bool) +checkUser :: Username -> String -> Query Blog Bool checkUser uN pw = do b@Blog{..} <- ask let user = getOne $ blogUsers @= uN case user of Nothing -> return False - (Just u) -> return $ (password u) == hashString pw + (Just u) -> return $ password u == hashString pw -- various functions hashString :: String -> ByteString @@ -251,7 +251,7 @@ flushSessions :: IO () flushSessions = do tbDir <- getEnv "TAZBLOG" acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState - update' acid (ClearSessions) + update' acid ClearSessions closeAcidState acid archiveState :: IO () diff --git a/src/Main.hs b/src/Main.hs index 09215ba9d54f..3f806328e536 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,7 +12,7 @@ module Main where import Control.Applicative (optional, pure, (<$>), (<*>)) import Control.Exception (bracket) -import Control.Monad (msum, mzero, unless, when) +import Control.Monad (liftM, msum, mzero, unless, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask) import Control.Monad.State (get, put) @@ -53,14 +53,14 @@ defineOptions "MainOptions" $ do "The port to run the web server on. Default is 8000" tmpPolicy :: BodyPolicy -tmpPolicy = (defaultBodyPolicy "./tmp/" 0 200000 1000) +tmpPolicy = defaultBodyPolicy "./tmp/" 0 200000 1000 main :: IO() main = do putStrLn ("TazBlog " ++ version ++ " in Haskell starting") runCommand $ \opts args -> bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState) - (createCheckpointAndClose) + createCheckpointAndClose (\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid $ optCaptcha opts) tazBlog :: AcidState Blog -> String -> ServerPart Response @@ -74,13 +74,13 @@ tazBlog acid captchakey = do , dir "res" $ serveDirectory DisableBrowsing [] "../res" , dir "notice" $ ok $ toResponse showSiteNotice {- :Admin handlers -} - , do dirs "admin/postentry" $ nullDir + , do dirs "admin/postentry" nullDir guardSession acid postEntry acid - , do dirs "admin/entrylist" $ dir (show DE) $ nullDir + , do dirs "admin/entrylist" $ dir (show DE) nullDir guardSession acid entryList acid DE - , do dirs "admin/entrylist" $ dir (show EN) $ nullDir + , do dirs "admin/entrylist" $ dir (show EN) nullDir guardSession acid entryList acid EN , do guardSession acid @@ -90,16 +90,16 @@ tazBlog acid captchakey = do , do guardSession acid dirs "admin/cdelete" $ path $ \(eId :: Integer) -> path $ \(cId :: String) -> deleteComment acid (EntryId eId) cId - , do dir "admin" $ nullDir + , do dir "admin" nullDir guardSession acid ok $ toResponse $ adminIndex ("tazjin" :: Text) - , dir "admin" $ ok $ toResponse $ adminLogin + , dir "admin" $ ok $ toResponse adminLogin , dir "dologin" $ processLogin acid - , do dirs "static/blogv34.css" $ nullDir + , do dirs "static/blogv34.css" nullDir setHeaderM "content-type" "text/css" setHeaderM "cache-control" "max-age=630720000" setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" - ok $ toResponse $ blogStyle + ok $ toResponse blogStyle , do setHeaderM "cache-control" "max-age=630720000" setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" dir "static" $ serveDirectory DisableBrowsing [] "../res" @@ -156,7 +156,7 @@ showRSS acid lang = do addComment :: AcidState Blog -> BlogLang -> String -> EntryId -> ServerPart Response addComment acid lang captchakey eId = do - now <- liftIO $ getCurrentTime >>= return + now <- liftIO getCurrentTime nCtext <- lookText' "ctext" nComment <- Comment <$> pure now <*> lookText' "cname" @@ -164,12 +164,12 @@ addComment acid lang captchakey eId = do -- captcha verification challenge <- look "recaptcha_challenge_field" response <- look "recaptcha_response_field" - (userIp, _) <- askRq >>= return . rqPeer + (userIp, _) <- liftM rqPeer askRq -- FIXME askRq >>= return . rqPeer validation <- liftIO $ validateCaptcha captchakey userIp challenge response case validation of Right _ -> update' acid (AddComment eId nComment) >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse()) - Left _ -> (liftIO $ putStrLn "Captcha failed") >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse()) + Left _ -> liftIO (putStrLn "Captcha failed") >> seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse()) commentEscape :: Text -> Text commentEscape = newlineEscape . ltEscape . gtEscape . ampEscape @@ -184,7 +184,7 @@ commentEscape = newlineEscape . ltEscape . gtEscape . ampEscape postEntry :: AcidState Blog -> ServerPart Response postEntry acid = do decodeBody tmpPolicy - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime let eId = timeToId now lang <- look "lang" nBtext <- lookText' "btext" @@ -245,16 +245,15 @@ guardSession :: AcidState Blog -> ServerPartT IO () guardSession acid = do (sId :: Text) <- readCookieValue "session" (uName :: Text) <- readCookieValue "sUser" - now <- liftIO $ getCurrentTime + 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 + (Just Session{..}) -> unless ((uName == username user) && sessionTimeDiff now sdate) + mzero where sessionTimeDiff :: UTCTime -> UTCTime -> Bool - sessionTimeDiff now sdate = (diffUTCTime now sdate) < 43200 + sessionTimeDiff now sdate = diffUTCTime now sdate < 43200 processLogin :: AcidState Blog -> ServerPart Response @@ -263,9 +262,9 @@ processLogin acid = do account <- lookText' "account" password <- look "password" login <- query' acid (CheckUser (Username account) password) - if' login - (createSession account) - (ok $ toResponse $ adminLogin) + if login + then createSession account + else ok $ toResponse adminLogin where createSession account = do now <- liftIO getCurrentTime diff --git a/src/RSS.hs b/src/RSS.hs index 50531c3f8065..045702ece443 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -2,14 +2,15 @@ module RSS (renderFeed) where -import qualified Data.Text as T +import qualified Data.Text as T -import Data.Maybe (fromMaybe) -import Data.Time (UTCTime, getCurrentTime) +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime, getCurrentTime) import Network.URI import Text.RSS -import BlogDB hiding (Title) +import BlogDB hiding (Title) import Locales createChannel :: BlogLang -> UTCTime -> [ChannelElem] @@ -20,7 +21,7 @@ createChannel l now = [ Language $ show l ] createRSS :: BlogLang -> UTCTime -> [Item] -> RSS -createRSS l t i = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) i +createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) createItem :: Entry -> Item createItem Entry{..} = [ Title $ T.unpack title @@ -39,4 +40,4 @@ createFeed :: BlogLang -> [Entry] -> IO RSS createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e ) renderFeed :: BlogLang -> [Entry] -> IO String -renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed) +renderFeed l e = liftM (showXML . rssToXML) (createFeed l e) |