hablog 0.5.1 → 0.6.0
raw patch · 7 files changed
+91/−8 lines, 7 filesdep +network-uridep +rssdep +time
Dependencies added: network-uri, rss, time
Files
- app/Main.hs +11/−0
- hablog.cabal +5/−2
- src/Web/Hablog/Config.hs +7/−2
- src/Web/Hablog/Html.hs +1/−0
- src/Web/Hablog/Post.hs +30/−0
- src/Web/Hablog/Present.hs +17/−0
- src/Web/Hablog/Run.hs +20/−4
app/Main.hs view
@@ -6,6 +6,7 @@ import Control.Monad (void) import Control.Concurrent (forkIO)+import Data.Monoid ((<>)) import Data.List (intercalate) import Data.Text.Lazy (pack, unpack) import Options.Applicative@@ -51,6 +52,7 @@ config = Config <$> fmap pack ttl <*> fmap snd thm+ <*> fmap pack domain where ttl = strOption@@ -60,6 +62,15 @@ <> help "Title for the blog" <> showDefault <> value (unpack defaultTitle)+ )+ domain =+ strOption+ (long "domain"+ <> short 'd'+ <> metavar "NAME"+ <> help "Website domain"+ <> showDefault+ <> value (unpack defaultDomain) )
hablog.cabal view
@@ -1,5 +1,5 @@ Name: hablog-Version: 0.5.1+Version: 0.6.0 Synopsis: A blog system Description: blog system with tags License: MIT@@ -12,7 +12,7 @@ Cabal-version: >=1.10 -tested-with: GHC==7.10+tested-with: GHC==8.0.2 extra-source-files: README.md@@ -39,6 +39,9 @@ ,filepath ,mime-types ,containers+ ,rss+ ,time+ ,network-uri exposed-modules: Web.Hablog
src/Web/Hablog/Config.hs view
@@ -15,8 +15,9 @@ -- | Configuration for Hablog data Config = Config- { blogTitle :: Text- , blogTheme :: Theme+ { blogTitle :: Text+ , blogTheme :: Theme+ , blogDomain :: Text } deriving (Show, Read) @@ -33,11 +34,15 @@ defaultConfig = Config { blogTitle = defaultTitle , blogTheme = snd defaultTheme+ , blogDomain = defaultDomain } -- | "Hablog" defaultTitle :: Text defaultTitle = "Hablog"++defaultDomain :: Text+defaultDomain = "localhost" -- | The default HTTP port is 80 defaultPort :: Int
src/Web/Hablog/Html.hs view
@@ -49,6 +49,7 @@ footer :: H.Html footer = H.footer ! A.class_ "footer" $ do+ H.div $ H.a ! A.href "/rss" $ "RSS feed" H.span "Powered by " H.a ! A.href "https://github.com/soupi/hablog" $ "Hablog"
src/Web/Hablog/Post.hs view
@@ -2,9 +2,14 @@ module Web.Hablog.Post where +import Data.Monoid ((<>)) import qualified Data.Text.Lazy as T import qualified Text.Blaze.Html5 as H import qualified Data.Map as M+import qualified Text.RSS as RSS+import Data.Time (fromGregorian, Day, UTCTime(..), secondsToDiffTime)+import Network.URI (parseURI)+import qualified Text.Blaze.Html.Renderer.Text as HR import Web.Hablog.Utils @@ -24,6 +29,12 @@ month p = case date p of { (_, m, _) -> m; } day p = case date p of { (_, _, d) -> d; } +toDay :: Post -> Maybe Day+toDay post =+ case (reads $ T.unpack $ year post, reads $ T.unpack $ month post, reads $ T.unpack $ day post) of+ ([(y,[])], [(m,[])], [(d,[])]) -> pure (fromGregorian y m d)+ _ -> Nothing+ toPost :: T.Text -> Maybe Post toPost fileContent = Post <$> ((,,) <$> yyyy <*> mm <*> dd)@@ -73,4 +84,23 @@ | year p1 == year p2 && month p1 == month p2 && day p1 < day p2 = LT | year p1 == year p2 && month p1 == month p2 && day p1 == day p2 = EQ | otherwise = GT+++toRSS :: T.Text -> Post -> RSS.Item+toRSS domain post =+ [ RSS.Title (T.unpack $ title post)+ ] ++ map (RSS.Author . T.unpack) (authors post)+ ++ map (RSS.Category Nothing . T.unpack) (tags post)+ ++ [ RSS.PubDate $ UTCTime d (secondsToDiffTime 0)+ | Just d <- [toDay post]+ ]+ ++ [ RSS.Link r+ | Just r <- (:[]) $ parseURI $+ T.unpack (domain <> "/" <> getPath post)+ ]+ ++ [ RSS.Description+ . T.unpack+ $ HR.renderHtml (content post)+ ]+
src/Web/Hablog/Present.hs view
@@ -10,6 +10,7 @@ import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Text.Blaze.Html.Renderer.Text as HR import qualified Text.Blaze.Html5 as H@@ -18,12 +19,14 @@ import qualified System.Directory as DIR (getDirectoryContents) import System.IO.Error (catchIOError)+import qualified Text.RSS as RSS import Web.Hablog.Html import Web.Hablog.Types import Web.Hablog.Config import qualified Web.Hablog.Post as Post import qualified Web.Hablog.Page as Page+import Network.URI (URI) presentMain :: HablogAction () presentMain = do@@ -42,6 +45,20 @@ H.h1 "Tags" tgs postsListHtml allPosts++presentRSS :: URI -> HablogAction ()+presentRSS domain = do+ cfg <- getCfg+ allPosts <- liftIO getAllPosts+ let mime = "application/rss+xml"+ setHeader "content-type" mime+ raw+ . BSLC.pack+ . RSS.showXML+ . RSS.rssToXML+ . RSS.RSS (T.unpack $ blogTitle cfg) domain "" []+ . map (Post.toRSS $ blogDomain cfg)+ $ allPosts showPostsWhere :: (Post.Post -> Bool) -> HablogAction () showPostsWhere test = do
src/Web/Hablog/Run.hs view
@@ -4,6 +4,7 @@ module Web.Hablog.Run where +import Data.Monoid import Web.Scotty.Trans import Web.Scotty.TLS (scottyTTLS) import Control.Monad.Trans.Reader (runReaderT)@@ -12,6 +13,9 @@ import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html.Renderer.Text as HR import qualified Network.Mime as Mime (defaultMimeLookup)+import Network.URI (URI, parseURI)+import Control.Monad+import Data.Maybe import Web.Hablog.Types import Web.Hablog.Config@@ -23,17 +27,29 @@ -- | Run Hablog on HTTP run :: Config -> Int -> IO () run cfg port =- scottyT port (`runReaderT` cfg) router+ scottyT port (`runReaderT` cfg') (router $! domain)+ where+ cfg' = cfg+ { blogDomain = "http://" <> blogDomain cfg <> ":" <> portStr }+ portStr = if port == 80 then "" else TL.pack (show port)+ domain = parseURI (TL.unpack $ blogDomain cfg') -- | Run Hablog on HTTPS runTLS :: TLSConfig -> Config -> IO () runTLS tlsCfg cfg =- scottyTTLS (blogTLSPort tlsCfg) (blogKey tlsCfg) (blogCert tlsCfg) (`runReaderT` cfg) router+ scottyTTLS (blogTLSPort tlsCfg) (blogKey tlsCfg) (blogCert tlsCfg) (`runReaderT` cfg') (router $! domain)+ where+ cfg' = cfg+ { blogDomain = "https://" <> blogDomain cfg <> ":" <> portStr }+ portStr = if blogTLSPort tlsCfg == 443 then "" else TL.pack (show (blogTLSPort tlsCfg))+ domain = parseURI (TL.unpack $ blogDomain cfg') -- | Hablog's router-router :: Hablog ()-router = do+router :: Maybe URI -> Hablog ()+router domain = do get "/" presentMain+ when (isJust domain)+ $ get "/rss" (presentRSS $ fromJust domain) get "/post/:yyyy/:mm/:dd/:title" $ do (yyyy, mm, dd) <- getDate title <- param "title"