Browse Source

refactoring Post

tags/v0.3
suppi 5 years ago
parent
commit
07088785fc
10 changed files with 142 additions and 122 deletions
  1. +3
    -0
      _posts/haskell-code-test.md
  2. +2
    -2
      hablog.cabal
  3. +24
    -24
      src/Hablog/Html.hs
  4. +0
    -55
      src/Hablog/Model.hs
  5. +0
    -10
      src/Hablog/Page.hs
  6. +64
    -0
      src/Hablog/Post.hs
  7. +31
    -28
      src/Hablog/Present.hs
  8. +1
    -1
      src/Hablog/Run.hs
  9. +2
    -2
      src/Hablog/Settings.hs
  10. +15
    -0
      src/Hablog/Utils.hs

_posts/2014-11-08-haskell-code-test.md → _posts/haskell-code-test.md View File

@@ -1,6 +1,9 @@
title: Haskell syntax highlight test
authors: Gil
route: haskell-code-test
date: 2014-11-08
tags: markdown, syntax, haskell, programming
---

Lets write some Haskell code
=============================

+ 2
- 2
hablog.cabal View File

@@ -11,7 +11,7 @@ Build-type: Simple

Cabal-version: >=1.10

tested-with: GHC==7.8
tested-with: GHC==7.10

extra-source-files:
README.md
@@ -38,11 +38,11 @@ library

exposed-modules:
Hablog.Run
Hablog.Model
Hablog.Settings
Hablog.Utils
Hablog.Present
Hablog.Page
Hablog.Post
Hablog.Html
exposed:
True


+ 24
- 24
src/Hablog/Html.hs View File

@@ -11,8 +11,8 @@ import qualified Text.Blaze.Html5.Attributes as A


import Hablog.Settings
import qualified Hablog.Model as Model
import qualified Hablog.Page as Page
import qualified Hablog.Post as Post
import qualified Hablog.Page as Page

template :: T.Text -> H.Html -> H.Html
template title container =
@@ -44,7 +44,7 @@ logo = H.header ! A.class_ "logo" $ H.h1 $ H.a ! A.href "/" $ H.toHtml blogTitle

footer :: H.Html
footer = H.footer ! A.class_ "footer" $ do
H.span $ "Powered by "
H.span "Powered by "
H.a ! A.href "https://github.com/soupi/hablog" $ "Hablog"

errorPage :: T.Text -> String -> H.Html
@@ -57,38 +57,38 @@ emptyPage :: H.Html
emptyPage = H.span " "


postsListHtml :: [Model.Post] -> H.Html
postsListHtml :: [Post.Post] -> H.Html
postsListHtml posts =
H.div ! A.class_ "PostsList" $ do
H.h1 "Posts"
postsList posts

postsList :: [Model.Post] -> H.Html
postsList :: [Post.Post] -> H.Html
postsList = H.ul . mconcat . fmap postsListItem

postsListItem :: Model.Post -> H.Html
postsListItem :: Post.Post -> H.Html
postsListItem post = H.li $ do
H.span ! A.class_ "postDate" $ H.toHtml $ Model.date post
H.span ! A.class_ "postDate" $ H.toHtml $ Post.date post
H.span ! A.class_ "seperator" $ " - "
H.a ! A.href (fromString ("/" ++ Model.getPath post)) $ H.toHtml $ Model.headerTitle post
H.a ! A.href (fromString $ T.unpack ("/" `T.append` Post.getPath post)) $ H.toHtml $ Post.title post

postPage :: Model.Post -> H.Html
postPage post = template (T.pack (Model.headerTitle post)) $ do
postPage :: Post.Post -> H.Html
postPage post = template (Post.title post) $
H.article ! A.class_ "post" $ do
H.div ! A.class_ "postTitle" $ do
H.a ! A.href (fromString ("/" ++ Model.getPath post)) $ H.h2 ! A.class_ "postHeader" $ H.toHtml (Model.headerTitle post)
H.a ! A.href (fromString $ T.unpack ("/" `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 $ Model.authors post
H.span ! A.class_ "postAuthor" $ H.toHtml $ authorsList $ Post.authors post
H.span ! A.class_ "seperator" $ " - "
H.span ! A.class_ "postDate" $ H.toHtml $ Model.date post
H.span ! A.class_ "postDate" $ H.toHtml $ Post.date post
H.span ! A.class_ "seperator" $ " - "
H.span ! A.class_ "postTags" $ tagsList (Model.tags post)
H.div ! A.class_ "postContent" $ Model.content post
H.span ! A.class_ "postTags" $ tagsList (Post.tags post)
H.div ! A.class_ "postContent" $ Post.content post

pagePage :: Page.Page -> H.Html
pagePage page = template (Page.getPageName page) $ do
pagePage page = template (Page.getPageName page) $
H.article ! A.class_ "post" $ do
H.div ! A.class_ "postTitle" $ 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

@@ -97,19 +97,19 @@ pagesList :: [Page.Page] -> H.Html
pagesList = H.ul . 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/" ++ Page.getPageURL page)) $ H.toHtml (Page.getPageName page)

tagsList :: [String] -> H.Html
tagsList :: [T.Text] -> H.Html
tagsList = H.ul . mconcat . fmap tagsListItem . sort

tagsListItem :: String -> H.Html
tagsListItem tag = H.li $ H.a ! A.href (fromString ("/tags/" ++ tag)) $ H.toHtml tag
tagsListItem :: T.Text -> H.Html
tagsListItem tag = H.li $ H.a ! A.href (fromString $ T.unpack ("/tags/" `T.append` tag)) $ H.toHtml tag

authorsList :: [String] -> H.Html
authorsList :: [T.Text] -> H.Html
authorsList = H.ul . mconcat . fmap authorsListItem . sort

authorsListItem :: String -> H.Html
authorsListItem author = H.li $ H.a ! A.href (fromString ("/authors/" ++ author)) $ H.toHtml author
authorsListItem :: T.Text -> H.Html
authorsListItem author = H.li $ H.a ! A.href (fromString $ T.unpack ("/authors/" `T.append` author)) $ H.toHtml author




+ 0
- 55
src/Hablog/Model.hs View File

@@ -1,55 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}

module Hablog.Model where

import Control.Applicative ((<$>),(<*>), pure)
import Data.Char (toLower)
import qualified Data.Text.Lazy as T (Text, pack, unpack, lines, unlines, concat)
import qualified Text.Markdown as MD
import qualified Text.Blaze.Html5 as H

import Hablog.Utils

data Post = Post { year :: String
, month :: String
, day :: String
, pathTitle :: String
, headerTitle :: String
, authors :: [String]
, tags :: [String]
, content :: H.Html }

toPost :: String -> T.Text -> Maybe Post
toPost path fileContent = Post <$> yyyy <*> mm <*> dd <*> pttl <*> httl <*> auth <*> tgs <*> pure (MD.markdown MD.def (T.unlines (dropWhile (/="") (T.lines fileContent))))
where as_list = splitBy '-' path
yyyy = (\x -> if length x > 1 then x `at` 1 else hd x) =<< fmap (splitBy '/') (hd as_list)
mm = as_list `at` 1
dd = as_list `at` 2
pttl = pure $ reverse $ drop 3 $ reverse $ convert '-' $ drop 3 as_list
header = takeWhile (/=[]) . lines . T.unpack $ fileContent
getHd p = takeJust $ fmap ((\x -> if hd x == Just p then Just (unwords (tail x)) else Nothing) . words) header
httl = getHd "title:"
auth = getList "authors:"
tgs = map (map toLower) <$> getList "tags:"
getList x = map removeWhitespaces . splitBy ',' <$> getHd x

getPath :: Post -> String
getPath post = concat ["post/", year post, "/", month post, "/", day post, "/", (pathTitle) post]

date :: Post -> T.Text
date post = T.concat $ map T.pack [day post, "/", month post, "/", year post]

instance Show Post where
show post = concat ["post/", year post, "/", month post, "/", day post, "/", (pathTitle) post]

instance Eq Post where
(==) p1 p2 = pathTitle p1 == pathTitle p2


instance Ord Post where
compare p1 p2
| year p1 < year p2 = LT
| year p1 == year p2 && month p1 < month p2 = LT
| 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

+ 0
- 10
src/Hablog/Page.hs View File

@@ -5,7 +5,6 @@ module Hablog.Page where
import Control.Arrow ((&&&))
import qualified Data.Map as M
import qualified Data.Text.Lazy as T
import qualified Text.Markdown as MD
import qualified Text.Blaze.Html5 as H

import Hablog.Utils
@@ -24,15 +23,6 @@ toPage fileContent =
<*> pure (createBody content)
where (header, content) = (getHeader &&& getContent) fileContent

getHeader :: T.Text -> M.Map T.Text T.Text
getHeader = M.fromList . filter ((/=)"" . snd) . map (partition ':') . takeWhile (not . T.isPrefixOf headerBreaker) . T.lines

getContent :: T.Text -> T.Text
getContent = T.unlines . dropWhile (T.isPrefixOf headerBreaker) . dropWhile (not . T.isPrefixOf headerBreaker) . T.lines

createBody :: T.Text -> H.Html
createBody = MD.markdown MD.def


instance Show Page where
show = getPageURL


+ 64
- 0
src/Hablog/Post.hs View File

@@ -0,0 +1,64 @@
{-# LANGUAGE OverloadedStrings #-}

module Hablog.Post where

import qualified Data.Text.Lazy as T
import qualified Text.Blaze.Html5 as H
import qualified Data.Map as M

import Hablog.Utils


data Post
= Post
{ year :: T.Text
, month :: T.Text
, day :: T.Text
, route :: T.Text
, title :: T.Text
, authors :: [T.Text]
, tags :: [T.Text]
, content :: H.Html
}

toPost :: T.Text -> Maybe Post
toPost fileContent =
Post <$> yyyy
<*> mm
<*> dd
<*> M.lookup "route" header
<*> M.lookup "title" header
<*> (map (T.unwords . T.words) . T.split (==',') <$> M.lookup "authors" header)
<*> (map (T.toLower . T.unwords . T.words) . T.split (==',') <$> M.lookup "tags" header)
<*> pure (createBody $ getContent fileContent)
where
header = getHeader fileContent
dt = T.split (=='-') <$> M.lookup "date" header
yyyy = dt >>= (`at` 0)
mm = dt >>= (`at` 1)
dd = dt >>= (`at` 2)

getPath :: Post -> T.Text
getPath post =
T.concat ["post/", year post, "/", month post, "/", day post, "/", route post]

date :: Post -> T.Text
date post =
T.concat [day post, "/", month post, "/", year post]

instance Show Post where
show post =
T.unpack $ T.concat ["post/", year post, "/", month post, "/", day post, "/", route post]

instance Eq Post where
(==) p1 p2 = route p1 == route p2


instance Ord Post where
compare p1 p2
| year p1 < year p2 = LT
| year p1 == year p2 && month p1 < month p2 = LT
| 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


+ 31
- 28
src/Hablog/Present.hs View File

@@ -18,9 +18,8 @@ import Text.Blaze.Html5 ((!))
import qualified System.Directory as DIR (getDirectoryContents)
import System.IO.Error (catchIOError)

import Hablog.Utils (removeWhitespaces)
import Hablog.Html
import qualified Hablog.Model as Model
import qualified Hablog.Post as Post
import qualified Hablog.Page as Page

presentMain :: ActionM ()
@@ -43,7 +42,7 @@ presentMain = do

presentPagesList :: [Page.Page] -> H.Html
presentPagesList [] = return ()
presentPagesList pages = do
presentPagesList pages =
H.div ! A.class_ "AllAuthorsList" $ do
H.h1 "Pages"
getPageList pages
@@ -62,18 +61,19 @@ getAllPages = do
contents <- catMaybes <$> mapM ((\x -> (pure <$> TIO.readFile x) `catchIOError` const (pure Nothing)) . ("_pages/"++)) pages
return . L.sortBy (flip compare) . catMaybes $ fmap Page.toPage (reverse contents)

getAllPosts :: IO [Model.Post]
getAllPosts :: IO [Post.Post]
getAllPosts = do
posts <- liftM (L.delete ".." . L.delete ".") (DIR.getDirectoryContents "_posts")
contents <- catMaybes <$> mapM ((\x -> (pure <$> TIO.readFile x) `catchIOError` const (pure Nothing)) . ("_posts/"++)) posts
return . L.sortBy (flip compare) . catMaybes $ fmap (uncurry Model.toPost) (reverse (zip posts contents))
pure . L.sortBy (flip compare) . catMaybes $ fmap Post.toPost (reverse contents)

presentPost :: T.Text -> T.Text -> ActionM ()
presentPost date title = do
myPost <- lift $ getPostFromFile date title
case postPage <$> myPost of
Just p -> html $ HR.renderHtml p
Nothing -> html $ HR.renderHtml $ errorPage "Hablog - 404: not found" "Could not find the page you were looking for."
presentPost :: T.Text -> ActionM ()
presentPost title = do
posts <- lift getAllPosts
case filter ((== title) . path) posts of
(p:_) -> html $ HR.renderHtml $ postPage p
[] -> html $ HR.renderHtml $ errorPage "Hablog - 404: not found" "Could not find the page you were looking for."
where path p = T.intercalate "/" ([Post.year, Post.month, Post.day, Post.route] <*> [p])

presentTags :: ActionM ()
presentTags = html . HR.renderHtml . template "Posts Tags" =<< lift getTagList
@@ -88,40 +88,43 @@ getPageList = pagesList
getAuthorsList :: IO H.Html
getAuthorsList = return . authorsList . getAllAuthors =<< getAllPosts

presentTag :: String -> ActionM ()
presentTag tag = html . HR.renderHtml . template (T.pack tag) . postsListHtml . filter (hasTag tag) =<< lift getAllPosts
presentTag :: T.Text -> ActionM ()
presentTag tag = html . HR.renderHtml . template tag . postsListHtml . filter (hasTag tag) =<< lift getAllPosts

presentAuthors :: ActionM ()
presentAuthors = html . HR.renderHtml . template "Posts Authors" =<< lift getAuthorsList

presentAuthor :: String -> ActionM ()
presentAuthor auth = html . HR.renderHtml . template (T.pack auth) . postsListHtml . filter (hasAuthor auth) =<< lift getAllPosts
presentAuthor :: T.Text -> ActionM ()
presentAuthor auth = html . HR.renderHtml . template auth . postsListHtml . filter (hasAuthor auth) =<< lift getAllPosts

getPageFromFile :: T.Text -> IO (Maybe Page.Page)
getPageFromFile title = do
let path = T.unpack $ mconcat ["_pages/", title]
getFromFile (const Page.toPage) path
getFromFile Page.toPage path

getPostFromFile :: T.Text -> T.Text -> IO (Maybe Model.Post)
getPostFromFile :: T.Text -> T.Text -> IO (Maybe Post.Post)
getPostFromFile date title = do
let postPath = T.unpack $ mconcat ["_posts/", date, "-", title, ".md"]
getFromFile Model.toPost postPath
getFromFile Post.toPost postPath

getFromFile :: (String -> T.Text -> Maybe a) -> String -> IO (Maybe a)
getFromFile :: (T.Text -> Maybe a) -> String -> IO (Maybe a)
getFromFile constructor path = do
fileContent <- (pure <$> TIO.readFile path) `catchIOError` const (pure Nothing)
let content = constructor path =<< fileContent
let content = constructor =<< fileContent
return content

getAllTags :: [Model.Post] -> [String]
getAllTags = L.sort . map (removeWhitespaces . head) . L.group . L.sort . concatMap Model.tags
getAllTags :: [Post.Post] -> [T.Text]
getAllTags = getAll Post.tags

hasTag :: String -> Model.Post -> Bool
hasTag tag = ([]/=) . filter (==tag) . Model.tags
hasTag :: T.Text -> Post.Post -> Bool
hasTag tag = ([]/=) . filter (==tag) . Post.tags

getAllAuthors :: [Model.Post] -> [String]
getAllAuthors = L.sort . map (removeWhitespaces . head) . L.group . L.sort . concatMap Model.authors
getAllAuthors :: [Post.Post] -> [T.Text]
getAllAuthors = getAll Post.authors

getAll :: (Post.Post -> [T.Text]) -> [Post.Post] -> [T.Text]
getAll f = L.sort . map (T.unwords . T.words . head) . L.group . L.sort . concatMap f

hasAuthor :: T.Text -> Post.Post -> Bool
hasAuthor auth myPost = auth `elem` Post.authors myPost

hasAuthor :: String -> Model.Post -> Bool
hasAuthor auth myPost = auth `elem` Model.authors myPost

+ 1
- 1
src/Hablog/Run.hs View File

@@ -29,7 +29,7 @@ router = do
mm <- param "mm"
dd <- param "dd"
title <- param "title"
presentPost (mconcat [yyyy,"-",mm,"-",dd]) title
presentPost (mconcat [yyyy,"/",mm,"/",dd, "/", title])
get (regex "/static/(.*)") $ do
path <- liftM (drop 1 . T.unpack) (param "0")
if hasdots path then


+ 2
- 2
src/Hablog/Settings.hs View File

@@ -18,7 +18,7 @@ blogPort = 80
data Theme = Theme { bgTheme :: AttributeValue, codeTheme :: AttributeValue }

darkTheme :: Theme
darkTheme = Theme "static/css/dark.css" "static/highlight/styles/hybrid.css"
darkTheme = Theme "/static/css/dark.css" "/static/highlight/styles/hybrid.css"

lightTheme :: Theme
lightTheme = Theme "static/css/light.css" "static/highlight/styles/docco.css"
lightTheme = Theme "/static/css/light.css" "/static/highlight/styles/docco.css"

+ 15
- 0
src/Hablog/Utils.hs View File

@@ -4,6 +4,9 @@ module Hablog.Utils where

import Control.Arrow ((&&&))
import qualified Data.Text.Lazy as T
import qualified Data.Map as M
import qualified Text.Markdown as MD
import qualified Text.Blaze.Html5 as H

hd :: [a] -> Maybe a
hd [] = Nothing
@@ -44,3 +47,15 @@ x |> f = f x
partition :: Char -> T.Text -> (T.Text, T.Text)
partition c = T.takeWhile (/=c) &&& (T.unwords . T.words . T.dropWhile (==c) . T.dropWhile (/=c))


getHeader :: T.Text -> M.Map T.Text T.Text
getHeader = M.fromList . filter ((/=)"" . snd) . map (partition ':') . takeWhile (not . T.isPrefixOf headerBreaker) . T.lines

getContent :: T.Text -> T.Text
getContent = T.unlines . dropWhile (T.isPrefixOf headerBreaker) . dropWhile (not . T.isPrefixOf headerBreaker) . T.lines

createBody :: T.Text -> H.Html
createBody = MD.markdown MD.def




Loading…
Cancel
Save