hablog 0.6.0 → 0.7.0
raw patch · 8 files changed
+225/−81 lines, 8 files
Files
- LICENSE +1/−1
- README.md +17/−1
- app/Main.hs +0/−1
- hablog.cabal +4/−4
- src/Web/Hablog/Html.hs +27/−21
- src/Web/Hablog/Post.hs +0/−1
- src/Web/Hablog/Present.hs +53/−27
- src/Web/Hablog/Run.hs +123/−25
LICENSE view
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016 Gil Mizrahi+Copyright (c) 2018 Gil Mizrahi Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -1,7 +1,7 @@ Hablog ====== -[](http://hackage.haskell.org/package/hablog) [](https://circleci.com/gh/soupi/hablog)+[](http://hackage.haskell.org/package/hablog) A simple blog platform with tags. Made with Haskell and Scotty. @@ -22,6 +22,22 @@ cd hablog stack build ```+++Running+=======++```+hablog --title <TITLE> --theme <THEME> --domain <DOMAIN> <COMMAND> [--port <PORT> --tls-cert <TLS_CERT> --tls-port <TLS_PORT>]+```++- `<TITLE>` is the title you want in the HTML headers;+- `<THEME>` is `light` or `dark`, depending on the theme you want, to create your own themes look at the examples in [/static/css](https://github.com/soupi/hablog/tree/master/static/css);+- `<DOMAIN>` is the domain you're running the blog on;+- `<COMMAND>` is `http`, `https`, or `both`;+- `<PORT>` is the `http` port (not required if `COMMAND` is `https`);+- `<TLS_CERT>` is the `https` certificate (not required if `COMMAND` is `http`);+- `<TLS_PORT>` is the `https` port (not required if `COMMAND` is `http`). How to write a new post?
app/Main.hs view
@@ -6,7 +6,6 @@ import Control.Monad (void) import Control.Concurrent (forkIO)-import Data.Monoid ((<>)) import Data.List (intercalate) import Data.Text.Lazy (pack, unpack) import Options.Applicative
hablog.cabal view
@@ -1,25 +1,25 @@ Name: hablog-Version: 0.6.0+Version: 0.7.0 Synopsis: A blog system Description: blog system with tags License: MIT license-file: LICENSE Author: Gil Mizrahi-Maintainer: soupiral@gmail.com+Maintainer: gilmi@posteo.net Stability: Experimental Category: Web Build-type: Simple Cabal-version: >=1.10 -tested-with: GHC==8.0.2+tested-with: GHC==8.8.4 extra-source-files: README.md source-repository head type: git- location: https://github.com/soupi/hablog+ location: https://gitlab.com/gilmi/hablog library Build-depends:
src/Web/Hablog/Html.hs view
@@ -14,23 +14,24 @@ import qualified Web.Hablog.Post as Post import qualified Web.Hablog.Page as Page -template :: Config -> Bool -> T.Text -> H.Html -> H.Html-template cfg highlight title container =+template :: Config -> Bool -> T.Text -> String -> H.Html -> H.Html+template cfg highlight title pageRoute container = H.docTypeHtml $ do H.head $ do H.title (H.toHtml (T.concat [blogTitle cfg, " - ", title]))+ H.meta ! A.content "width=650" ! A.name "viewport" H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href (H.stringValue . bgTheme $ blogTheme cfg) if highlight then H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href (H.stringValue . codeTheme $ blogTheme cfg) else mempty H.body $ do H.div ! A.class_ "container" $ do- logo cfg+ logo cfg pageRoute H.div ! A.class_ "maincontainer" $ container footer if highlight then do- H.script ! A.src "static/highlight/highlight.pack.js" $ ""+ H.script ! A.src "/static/highlight/highlight.pack.js" $ "" H.script "hljs.initHighlightingOnLoad();" else mempty@@ -40,22 +41,24 @@ notFoundPage :: Config -> H.Html notFoundPage cfg =- template cfg False "Not Found" $ mainTemplate $ do+ template cfg False "Not Found" "notfound" $ mainTemplate $ do H.h1 "Not found" H.p "The page you search for is not available." -logo :: Config -> H.Html-logo cfg = H.header ! A.class_ "logo" $ H.h1 $ H.a ! A.href "/" $ H.toHtml (blogTitle cfg)+logo :: Config -> String -> H.Html+logo cfg pageRoute = H.header ! A.class_ "logo" $ H.h1 $ do+ H.a ! A.href (H.stringValue $ "/" ++ pageRoute) $ H.toHtml (blogTitle cfg)+ "/" >> H.toHtml pageRoute footer :: H.Html footer = H.footer ! A.class_ "footer" $ do- H.div $ H.a ! A.href "/rss" $ "RSS feed"+ H.div $ H.a ! A.href "/blog/rss" $ "RSS feed" H.span "Powered by " H.a ! A.href "https://github.com/soupi/hablog" $ "Hablog" errorPage :: Config -> T.Text -> String -> H.Html errorPage cfg ttl msg =- template cfg False ttl $ do+ template cfg False ttl "" $ do H.h2 "Something Went Wrong..." H.p $ H.toHtml msg @@ -76,13 +79,13 @@ postsListItem post = H.li $ do H.span ! A.class_ "postDate" $ H.toHtml $ Post.getDate post H.span ! A.class_ "seperator" $ " - "- H.a ! A.href (fromString $ T.unpack ("/" `T.append` Post.getPath post)) $ H.toHtml $ Post.title post+ H.a ! A.href (fromString $ T.unpack ("/blog/" `T.append` Post.getPath post)) $ H.toHtml $ Post.title post postPage :: Config -> Post.Post -> H.Html-postPage cfg post = template cfg True (Post.title post) $+postPage cfg post = template cfg True (Post.title post) "blog" $ H.article ! A.class_ "post" $ do H.div ! A.class_ "postTitle" $ do- H.a ! A.href (fromString $ T.unpack ("/" `T.append` Post.getPath post)) $ H.h2 ! A.class_ "postHeader" $ H.toHtml (Post.title post)+ H.a ! A.href (fromString $ T.unpack ("/blog/" `T.append` Post.getPath post)) $ H.h2 ! A.class_ "postHeader" $ H.toHtml (Post.title post) H.span ! A.class_ "postSubTitle" $ do H.span ! A.class_ "postAuthor" $ H.toHtml $ authorsList $ Post.authors post H.span ! A.class_ "seperator" $ " - "@@ -92,30 +95,33 @@ H.div ! A.class_ "postContent" $ Post.content post pagePage :: Config -> Page.Page -> H.Html-pagePage cfg page = template cfg True (Page.getPageName page) $- H.article ! A.class_ "post" $ do- H.div ! A.class_ "postTitle" $- H.a ! A.href (fromString (Page.getPageURL page)) $ H.h2 ! A.class_ "postHeader" $ H.toHtml (Page.getPageName page)- H.div ! A.class_ "postContent" $ Page.getPageContent page+pagePage cfg page = template cfg True (Page.getPageName page) (Page.getPageURL page) $ pageContent page +pageContent :: Page.Page -> H.Html+pageContent page = do+ H.article ! A.class_ "post" $ do+ H.div ! A.class_ "postContent" $ Page.getPageContent page pagesList :: [Page.Page] -> H.Html-pagesList = H.ul . mconcat . fmap pagesListItem . sort+pagesList = mconcat . fmap pagesListItem . sort pagesListItem :: Page.Page -> H.Html-pagesListItem page = H.li $ H.a ! A.href (fromString ("/page/" ++ Page.getPageURL page)) $ H.toHtml (Page.getPageName page)+pagesListItem page =+ H.li+ $ H.a ! A.href (fromString ("/" ++ Page.getPageURL page))+ $ H.toHtml (Page.getPageName page) tagsList :: [T.Text] -> H.Html tagsList = H.ul . mconcat . fmap tagsListItem . sort tagsListItem :: T.Text -> H.Html-tagsListItem tag = H.li $ H.a ! A.href (fromString $ T.unpack ("/tags/" `T.append` tag)) $ H.toHtml tag+tagsListItem tag = H.li $ H.a ! A.href (fromString $ T.unpack ("/blog/tags/" `T.append` tag)) $ H.toHtml tag authorsList :: [T.Text] -> H.Html authorsList = H.ul . mconcat . fmap authorsListItem . sort authorsListItem :: T.Text -> H.Html-authorsListItem author = H.li $ H.a ! A.href (fromString $ T.unpack ("/authors/" `T.append` author)) $ H.toHtml author+authorsListItem author = H.li $ H.a ! A.href (fromString $ T.unpack ("/blog/authors/" `T.append` author)) $ H.toHtml author
src/Web/Hablog/Post.hs view
@@ -2,7 +2,6 @@ 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
src/Web/Hablog/Present.hs view
@@ -28,23 +28,44 @@ import qualified Web.Hablog.Page as Page import Network.URI (URI) -presentMain :: HablogAction ()-presentMain = do++presentHome :: HablogAction ()+presentHome = do+ allPages <- liftIO getAllPages+ cfg <- getCfg+ case L.find (\p -> Page.getPageURL p == "home") allPages of+ Nothing -> presentBlog+ Just homePage -> do+ html $ HR.renderHtml $ template cfg False "home" "home" $ do+ H.nav ! A.class_ "menu" $ do+ H.ul ! A.class_ "pages" $ do+ pagesList allPages+ H.li $ H.a ! A.href "/blog" $ "Blog"+ H.div ! A.class_ "content" $ do+ pageContent homePage+++presentBlog :: HablogAction ()+presentBlog = do allPosts <- liftIO getAllPosts allPages <- liftIO getAllPages tgs <- liftIO getTagList auths <- liftIO getAuthorsList cfg <- getCfg- html $ HR.renderHtml $ template cfg False "Posts" $ do- H.aside ! A.class_ "aside" $ do- presentPagesList allPages- H.div ! A.class_ "AllAuthorsList" $ do- H.h1 "Authors"- auths- H.div ! A.class_ "AllTagsList" $ do- H.h1 "Tags"- tgs- postsListHtml allPosts+ html $ HR.renderHtml $ template cfg False "Blog" "blog" $ do+ H.nav ! A.class_ "menu" $ do+ H.ul ! A.class_ "pages" $ do+ pagesList allPages+ H.li $ H.a ! A.href "/blog" $ "Blog"+ H.div ! A.class_ "main-content" $ do+ postsListHtml allPosts+ H.aside ! A.class_ "aside" $ do+ H.div ! A.class_ "AllAuthorsList" $ do+ H.h1 "Authors"+ auths+ H.div ! A.class_ "AllTagsList" $ do+ H.h1 "Tags"+ tgs presentRSS :: URI -> HablogAction () presentRSS domain = do@@ -64,21 +85,26 @@ showPostsWhere test = do cfg <- getCfg allPosts <- liftIO getAllPosts- html $ HR.renderHtml $ template cfg False "Posts" $+ html $ HR.renderHtml $ template cfg False "Posts" "blog" $ postsListHtml $ filter test allPosts -presentPagesList :: [Page.Page] -> H.Html-presentPagesList [] = pure ()-presentPagesList pages =- H.div ! A.class_ "AllAuthorsList" $ do- H.h1 "Pages"- getPageList pages+presentPage :: T.Text -> HablogAction ()+presentPage route = do+ pages <- liftIO getAllPages+ showOrNotFound (presentPage' pages) . filter (((==) $ T.unpack $ T.toLower route) . Page.getPageURL) $ pages +presentPage' :: [Page.Page] -> Config -> Page.Page -> H.Html+presentPage' pages cfg page = do+ template cfg False (Page.getPageName page) (Page.getPageURL page) $ do+ H.nav ! A.class_ "menu" $ do+ H.ul ! A.class_ "pages" $ do+ pagesList pages+ H.li $ H.a ! A.href "/blog" $ "Blog"+ H.div ! A.class_ "content" $ do+ pageContent page -presentPage :: T.Text -> HablogAction ()-presentPage title =- showOrNotFound pagePage . filter ((== T.unpack title) . Page.getPageURL) =<< liftIO getAllPages + getAllPages :: IO [Page.Page] getAllPages = getAllFromDir Page.toPage "_pages" @@ -108,13 +134,13 @@ presentTags = do cfg <- getCfg tags <- liftIO getTagList- html . HR.renderHtml $ template cfg False "Posts Tags" tags+ html . HR.renderHtml $ template cfg False "Posts Tags" "blog" tags getTagList :: IO H.Html getTagList = pure . tagsList . getAllTags =<< getAllPosts getPageList :: [Page.Page] -> H.Html-getPageList = pagesList+getPageList = H.ul . pagesList getAuthorsList :: IO H.Html@@ -124,19 +150,19 @@ presentTag tag = do cfg <- getCfg posts <- liftIO getAllPosts- html . HR.renderHtml . template cfg False tag $ postsListHtml $ filter (hasTag tag) posts+ html . HR.renderHtml . template cfg False tag "blog" $ postsListHtml $ filter (hasTag tag) posts presentAuthors :: HablogAction () presentAuthors = do cfg <- getCfg authors <- liftIO getAuthorsList- html . HR.renderHtml $ template cfg False "Posts Authors" authors+ html . HR.renderHtml $ template cfg False "Posts Authors" "blog" authors presentAuthor :: T.Text -> HablogAction () presentAuthor auth = do cfg <- getCfg posts <- liftIO getAllPosts- html . HR.renderHtml . template cfg False auth . postsListHtml $ filter (hasAuthor auth) posts+ html . HR.renderHtml . template cfg False auth "blog" . postsListHtml $ filter (hasAuthor auth) posts getPageFromFile :: T.Text -> IO (Maybe Page.Page) getPageFromFile title = do
src/Web/Hablog/Run.hs view
@@ -4,7 +4,6 @@ module Web.Hablog.Run where -import Data.Monoid import Web.Scotty.Trans import Web.Scotty.TLS (scottyTTLS) import Control.Monad.Trans.Reader (runReaderT)@@ -15,7 +14,11 @@ import qualified Network.Mime as Mime (defaultMimeLookup) import Network.URI (URI, parseURI) import Control.Monad+import Control.Monad.Trans import Data.Maybe+import Data.Time+import Data.List (isPrefixOf)+import System.Directory import Web.Hablog.Types import Web.Hablog.Config@@ -47,13 +50,13 @@ -- | Hablog's router 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"- presentPost (mconcat [yyyy,"/",mm,"/",dd, "/", title])+ get ("/favicon.ico") $ do+ let+ path = "static/favicon.ico"+ mime = Mime.defaultMimeLookup (T.pack path)+ setHeader "content-type" $ TL.fromStrict (T.decodeUtf8 mime)+ file path+ get (regex "/static/(.*)") $ do path <- fmap (drop 1 . T.unpack) (param "0") if hasdots path then@@ -62,39 +65,134 @@ let mime = Mime.defaultMimeLookup (T.pack path) setHeader "content-type" $ TL.fromStrict (T.decodeUtf8 mime) file path- get "/post/:yyyy/:mm/:dd" $ do++ get (regex "(.*)") $ do+ path <- fmap (drop 1 . T.unpack) (param "0")+ when ("apple" `isPrefixOf` path) $ next+ agent <- header "User-Agent"+ liftIO $ do+ hablogDir <- (<> "/.hablog") <$> getHomeDirectory+ createDirectoryIfMissing False hablogDir+ time <- getCurrentTime+ let+ date = formatTime defaultTimeLocale "%F" time+ datetime = formatTime defaultTimeLocale "%F %T" time+ replaceChar from to char+ | char == from = to+ | otherwise = char+ entry = concat+ [ "\""+ , map (replaceChar '\"' '_' . replaceChar ',' '_') path+ , "\" , "+ , date+ , " , "+ , datetime+ , " , "+ , "\""+ , maybe "" TL.unpack agent+ , "\""+ , "\n"+ ]+ appendFile (hablogDir <> "/visits.csv") entry+ next++ get "/" presentHome++ get "/blog" presentBlog++ route domain++ get "/:page" $ do+ page <- param "page"+ presentPage (TL.toLower page)++ notFound $ do+ cfg <- getCfg+ html $ HR.renderHtml $ errorPage cfg (blogTitle cfg `TL.append` " - 404: not found") "404 - Could not find the page you were looking for."++ where+ hasdots [] = False+ hasdots ('.':'.':_) = True+ hasdots (_:rest) = hasdots rest+++route :: Maybe URI -> Hablog ()+route domain = do+ when (isJust domain)+ $ get "/blog/rss" (presentRSS $ fromJust domain)++ get "/blog/post/:yyyy/:mm/:dd/:title" $ do (yyyy, mm, dd) <- getDate+ title <- param "title"+ presentPost (mconcat [yyyy,"/",mm,"/",dd, "/", title])++ get "/blog/post/:yyyy/:mm/:dd" $ do+ (yyyy, mm, dd) <- getDate showPostsWhere (eqDate (yyyy, mm, dd))- get "/post/:yyyy/:mm" $ do++ get "/blog/post/:yyyy/:mm" $ do yyyy <- param "yyyy" mm <- param "mm" showPostsWhere (eqYM (yyyy, mm))- get "/post/:yyyy" $ do++ get "/blog/post/:yyyy" $ do yyyy <- param "yyyy" showPostsWhere (eqY yyyy)- get "/tags"++ get "/blog/tags" presentTags- get "/tags/:tag" $ do++ get "/blog/tags/:tag" $ do tag <- param "tag" presentTag tag- get "/authors"++ get "/blog/authors" presentAuthors- get "/authors/:author" $ do++ get "/blog/authors/:author" $ do author <- param "author" presentAuthor author- get "/page/:page" $ do- page <- param "page"- presentPage page- notFound $ do- cfg <- getCfg- html $ HR.renderHtml $ errorPage cfg (blogTitle cfg `TL.append` " - 404: not found") "404 - Could not find the page you were looking for." + -- redirects++ when (isJust domain)+ $ get "/rss" $ do+ redirect "/blog/rss"++ get "/post/:yyyy/:mm/:dd/:title" $ do+ (yyyy, mm, dd) <- getDate+ title <- param "title"+ redirect $ mconcat ["/blog/post/", yyyy, "/", mm, "/", dd, "/", title]++ get "/post/:yyyy/:mm/:dd" $ do+ (yyyy, mm, dd) <- getDate+ redirect $ mconcat ["/blog/post/", yyyy, "/", mm, "/", dd]++ get "/post/:yyyy/:mm" $ do+ yyyy <- param "yyyy"+ mm <- param "mm"+ redirect $ mconcat ["/blog/post/", yyyy, "/", mm]++ get "/post/:yyyy" $ do+ yyyy <- param "yyyy"+ redirect $ mconcat ["/blog/post/", yyyy]++ get "/tags" $ do+ redirect "/blog/tags"++ get "/tags/:tag" $ do+ tag <- param "tag"+ redirect $ mconcat ["/blog/tags/", tag]++ get "/authors" $ do+ redirect "/blog/authors"++ get "/authors/:author" $ do+ author <- param "author"+ redirect $ mconcat ["/blog/authors/", author]+ where getDate = (,,) <$> param "yyyy" <*> param "mm" <*> param "dd"-- hasdots [] = False- hasdots ('.':'.':_) = True- hasdots (_:rest) = hasdots rest