packages feed

hablog (empty) → 0.4.0

raw patch · 14 files changed

+849/−0 lines, 14 filesdep +basedep +bifunctorsdep +blaze-htmlsetup-changed

Dependencies added: base, bifunctors, blaze-html, blaze-markup, bytestring, containers, directory, filepath, hablog, markdown, mime-types, mtl, scotty, scotty-tls, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,56 @@+Hablog+======++A simple blog platform with tags. Made with Haskell and Scotty.++Hablog will read posts written in Markdown from the `_posts` folder.++License+=======++Hablog is licensed under MIT license. This means the Haskell source files in the src directory.+Highlight.js related content is not a part of Hablog and is not licensed by it.+++Installation+============++```sh+git clone https://github.com/soupi/hablog+cd hablog+stack build+```+++How to write a new post?+========================++1. All posts must go under the `/_posts/` directory+1. All pages must go under the `/_pages/` directory+3. The content of the post/page must correspond to a specific structure++## A Post's Structure++```markdown+title: <the title of the post>+route: <route to the post>+authors: <the author of the post, seperated, by, commas>+date: yyyy-mm-dd+tags: <tags for the post, separated, by, commas>++---++<The rest of the post in Markdown format>+```+++## A Page's Structure++```markdown+title: <the title of the page>+route: <route to the page>+---++<The rest of the page in Markdown format>+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,59 @@+-- | A simple executable to run Hablog++{-# LANGUAGE LambdaCase #-}++module Main where++import Control.Monad (void)+import Control.Concurrent (forkIO)+import System.Environment (getArgs)+import Web.Hablog++main :: IO ()+main =+  getArgs >>= \case+    [] ->+      run defaultConfig defaultPort++    ["both", portStr, tlsPortStr, key, cert] ->+      case (reads portStr, reads tlsPortStr) of+        ([(port, "")], [(tlsPort, "")]) -> do+            void $ forkIO $ run defaultConfig port+            runTLS+              TLSConfig { blogTLSPort = tlsPort, blogKey = key, blogCert = cert }+              defaultConfig+        _ ->+            putStrLn usageMsgBoth+    ["tls", portStr, key, cert] ->+      case reads portStr of+        [(port, "")] ->+            runTLS+              TLSConfig { blogTLSPort = port, blogKey = key, blogCert = cert }+              defaultConfig+        _ ->+          putStrLn usageMsgTLS+    [portStr] ->+      case reads portStr of+        [(port, "")] ->+          run defaultConfig port+        _ ->+          putStrLn usageMsg+    _ ->+      putStrLn usageMsg++usageMsg :: String+usageMsg =+  unlines+    [ "Usage: hablog <port>"+    , "or"+    , usageMsgTLS+    , "or"+    , usageMsgBoth+    ]++usageMsgTLS :: String+usageMsgTLS = "Usage: hablog tls <port> <key file> <cert file>"++usageMsgBoth :: String+usageMsgBoth = "Usage: hablog both <port> <port tls> <key file> <cert file>"+
+ hablog.cabal view
@@ -0,0 +1,91 @@+Name:                hablog+Version:             0.4.0+Synopsis:            A blog system+Description:         blog system with tags+License:             MIT+license-file:        LICENSE+Author:              Gil Mizrahi+Maintainer:          soupiral@gmail.com+Stability:           Experimental+Category:            Web+Build-type:          Simple++Cabal-version:       >=1.10++tested-with: GHC==7.10++extra-source-files:+  README.md++source-repository head+  type: git+  location: https://github.com/soupi/hablog++library+  Build-depends:+    base >=4.7 && <5+   ,scotty+   ,scotty-tls >= 0.4+   ,blaze-html+   ,blaze-markup+   ,text+   ,mtl+   ,transformers+   ,bytestring+   ,bifunctors+   ,transformers+   ,markdown+   ,directory+   ,filepath+   ,mime-types+   ,containers++  exposed-modules:+    Web.Hablog+    Web.Hablog.Run+    Web.Hablog.Config+    Web.Hablog.Types++  other-modules:+    Web.Hablog.Utils+    Web.Hablog.Html+    Web.Hablog.Post+    Web.Hablog.Page+    Web.Hablog.Present++  exposed:+    True++  buildable:+    True++  hs-source-dirs:+    src++  default-language:+    Haskell2010++  if impl(ghc >= 6.12.0)+    other-extensions:+      FlexibleInstances+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+  else+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++Executable hablog+  hs-source-dirs: app+  main-is: Main.hs++  Build-depends:+     base+    ,hablog++  default-language:+    Haskell2010++  if impl(ghc >= 6.12.0)+    other-extensions:+      FlexibleInstances+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields+  else+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields
+ src/Web/Hablog.hs view
@@ -0,0 +1,15 @@+-- | Hablog is a simple blog which fetches contents from disc.+--   It features posts, tags, multiple authors, code highlighting and more.+--   For more information, consult the README++module Web.Hablog+  ( -- * Modules+    module Web.Hablog.Run+  , module Web.Hablog.Types+  , module Web.Hablog.Config+  )+  where++import Web.Hablog.Run+import Web.Hablog.Types+import Web.Hablog.Config
+ src/Web/Hablog/Config.hs view
@@ -0,0 +1,57 @@+-- | Configuration for Hablog++{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Config where++import Data.Text.Lazy (Text)+import Text.Blaze.Internal (AttributeValue)++-- | Data type to set the theme for your Hablog blog+data Theme = Theme+  { bgTheme   :: AttributeValue -- ^ General theme for hablog. a file path for a css file+  , codeTheme :: AttributeValue -- ^ Theme for code. a file path for a highlight.js css file+  }++-- | Configuration for Hablog+data Config = Config+  { blogTitle :: Text+  , blogTheme :: Theme+  }++-- | Requires the needed values for runTLS+data TLSConfig = TLSConfig+  { blogTLSPort :: Int+  , blogCert    :: FilePath+  , blogKey     :: FilePath+  }++-- | A default configuration+defaultConfig :: Config+defaultConfig = Config+  { blogTitle = defaultTitle+  , blogTheme = defaultTheme+  }++-- | "Hablog"+defaultTitle :: Text+defaultTitle = "Hablog"++-- | The default HTTP port is 80+defaultPort :: Int+defaultPort = 80++-- | The default HTTPS port is 443+defaultTLSPort :: Int+defaultTLSPort = 443++-- | The default is the dark theme+defaultTheme :: Theme+defaultTheme = darkTheme++darkTheme :: Theme+darkTheme = Theme "/static/css/dark.css" "/static/highlight/styles/hybrid.css"++lightTheme :: Theme+lightTheme  = Theme "/static/css/light.css" "/static/highlight/styles/docco.css"+
+ src/Web/Hablog/Html.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Html where++import Data.String (fromString)+import Data.List (sort)+import qualified Data.Text.Lazy as T+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5.Attributes as A+++import Web.Hablog.Config+import qualified Web.Hablog.Post as Post+import qualified Web.Hablog.Page as Page++template :: Config -> T.Text -> H.Html -> H.Html+template cfg title container =+  H.docTypeHtml $ do+    H.head $ do+      H.title (H.toHtml (T.concat [blogTitle cfg, " - ", title]))+      H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href (bgTheme $ blogTheme cfg)+      H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href (codeTheme $ blogTheme cfg)+    H.body $ do+      H.div ! A.class_ "container" $ do+        logo cfg+        H.div ! A.class_ "maincontainer" $ container+        footer+      H.script ! A.src "static/highlight/highlight.pack.js" $ ""+      H.script "hljs.initHighlightingOnLoad();"+++mainTemplate :: H.Html -> H.Html+mainTemplate = H.article ! A.class_ "content"++notFoundPage :: Config -> H.Html+notFoundPage cfg =+  template cfg "Not Found" $ 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)++footer :: H.Html+footer = H.footer ! A.class_ "footer" $ do+    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 ttl $ do+    H.h2 "Something Went Wrong..."+    H.p $ H.toHtml msg++emptyPage :: H.Html+emptyPage = H.span " "+++postsListHtml :: [Post.Post] -> H.Html+postsListHtml posts =+   H.div ! A.class_ "PostsList" $ do+    H.h1 "Posts"+    postsList posts++postsList :: [Post.Post] -> H.Html+postsList = H.ul . mconcat . fmap postsListItem++postsListItem :: Post.Post -> H.Html+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++postPage :: Config -> Post.Post -> H.Html+postPage cfg post = template cfg (Post.title post) $+    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.span ! A.class_ "postSubTitle" $ do+          H.span ! A.class_ "postAuthor" $ H.toHtml $ authorsList $ Post.authors post+          H.span ! A.class_ "seperator" $ " - "+          H.span ! A.class_ "postDate" $ H.toHtml $ Post.getDate post+          H.span ! A.class_ "seperator" $ " - "+          H.span ! A.class_ "postTags" $ tagsList (Post.tags post)+      H.div ! A.class_ "postContent" $ Post.content post++pagePage :: Config -> Page.Page -> H.Html+pagePage cfg page = template cfg (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+++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)++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++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+++
+ src/Web/Hablog/Page.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Page where++import           Control.Arrow  ((&&&))+import qualified Data.Map as M+import qualified Data.Text.Lazy as T+import qualified Text.Blaze.Html5 as H++import Web.Hablog.Utils++data Page+    = Page+    { getPageURL     :: FilePath+    , getPageName    :: T.Text+    , getPageContent :: H.Html+    }++toPage :: T.Text -> Maybe Page+toPage fileContent =+  Page <$> fmap T.unpack (M.lookup "route" header)+       <*> M.lookup "title" header+       <*> pure (createBody content)+    where (header, content) = (getHeader &&& getContent) fileContent+++instance Show Page where+  show = getPageURL++instance Eq Page where+  (==) p1 p2 = getPageURL p1 == getPageURL p2++instance Ord Page where+  compare p1 p2+    | getPageName p1 < getPageName p2 = LT+    | otherwise = GT+
+ src/Web/Hablog/Post.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Post where++import qualified Data.Text.Lazy as T+import qualified Text.Blaze.Html5 as H+import qualified Data.Map as M++import Web.Hablog.Utils+++data Post+  = Post+  { date  :: (T.Text, T.Text, T.Text)+  , route :: T.Text+  , title :: T.Text+  , authors :: [T.Text]+  , tags    :: [T.Text]+  , content :: H.Html+  }++year, month, day :: Post -> T.Text+year  p = case date p of { (y, _, _) -> y; }+month p = case date p of { (_, m, _) -> m; }+day   p = case date p of { (_, _, d) -> d; }++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]++getDate :: Post -> T.Text+getDate post =+  T.concat [day post, "/", month post, "/", year post]++eqY, eqM, eqD :: T.Text -> Post -> Bool+eqY y p = y == year  p+eqM m p = m == month p+eqD d p = d == day   p++eqYM :: (T.Text, T.Text) -> Post -> Bool+eqYM (y,m) p = eqY y p && eqM m p++eqDate :: (T.Text, T.Text, T.Text) -> Post -> Bool+eqDate dt p = dt == date p++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+
+ src/Web/Hablog/Present.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Present where++import           Web.Scotty.Trans+import           Control.Monad.IO.Class (liftIO)+import           Data.Maybe (catMaybes)+import           Data.Either (rights)+import qualified Data.List as L+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.ByteString.Lazy as BSL++import qualified Text.Blaze.Html.Renderer.Text as HR+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import           Text.Blaze.Html5 ((!))++import qualified System.Directory as DIR (getDirectoryContents)+import           System.IO.Error (catchIOError)++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++presentMain :: HablogAction ()+presentMain = do+  allPosts <- liftIO getAllPosts+  allPages <- liftIO getAllPages+  tgs <- liftIO getTagList+  auths <- liftIO getAuthorsList+  cfg <- getCfg+  html $ HR.renderHtml $ template cfg "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++showPostsWhere :: (Post.Post -> Bool) -> HablogAction ()+showPostsWhere test = do+  cfg <- getCfg+  allPosts <- liftIO getAllPosts+  html $ HR.renderHtml $ template cfg "Posts" $+    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 title =+  showOrNotFound pagePage . filter ((== T.unpack title) . Page.getPageURL) =<< liftIO getAllPages++getAllPages :: IO [Page.Page]+getAllPages = getAllFromDir Page.toPage "_pages"++getAllPosts :: IO [Post.Post]+getAllPosts = getAllFromDir Post.toPost "_posts"++getAllFromDir :: Ord a => (T.Text -> Maybe a) -> FilePath -> IO [a]+getAllFromDir parse dir = do+  posts <- fmap (L.delete ".." . L.delete ".") (DIR.getDirectoryContents dir `catchIOError` (\_ -> pure []))+  contents <- rights <$> mapM ((\x -> (T.decodeUtf8' <$> BSL.readFile x) `catchIOError` const (pure $ Left undefined)) . ((dir++"/")++)) posts+  pure . L.sortBy (flip compare) . catMaybes $ fmap parse (reverse contents)++presentPost :: T.Text -> HablogAction ()+presentPost title = do+  posts <- liftIO getAllPosts+  showOrNotFound postPage $ filter ((== title) . path) posts+  where path p = T.intercalate "/" ([Post.year, Post.month, Post.day, Post.route] <*> [p])++showOrNotFound :: (Config -> a -> H.Html) -> [a] -> HablogAction ()+showOrNotFound showP result = do+  cfg <- getCfg+  case result of+    (p:_) -> html $ HR.renderHtml $ showP cfg p+    []    -> html $ HR.renderHtml $ errorPage cfg "Hablog - 404: not found" "Could not find the page you were looking for."++presentTags :: HablogAction ()+presentTags = do+  cfg <- getCfg+  tags <- liftIO getTagList+  html . HR.renderHtml $ template cfg "Posts Tags" tags++getTagList :: IO H.Html+getTagList = pure . tagsList . getAllTags =<< getAllPosts++getPageList :: [Page.Page] -> H.Html+getPageList = pagesList+++getAuthorsList :: IO H.Html+getAuthorsList = pure . authorsList . getAllAuthors =<< getAllPosts++presentTag :: T.Text -> HablogAction ()+presentTag tag = do+  cfg <- getCfg+  posts <- liftIO getAllPosts+  html . HR.renderHtml . template cfg tag $ postsListHtml $ filter (hasTag tag) posts++presentAuthors :: HablogAction ()+presentAuthors = do+  cfg <- getCfg+  authors <- liftIO getAuthorsList+  html . HR.renderHtml $ template cfg "Posts Authors" authors++presentAuthor :: T.Text -> HablogAction ()+presentAuthor auth = do+  cfg <- getCfg+  posts <- liftIO getAllPosts+  html . HR.renderHtml . template cfg auth . postsListHtml $ filter (hasAuthor auth) posts++getPageFromFile :: T.Text -> IO (Maybe Page.Page)+getPageFromFile title = do+  let path = T.unpack $ mconcat ["_pages/", title]+  getFromFile Page.toPage path++getPostFromFile :: T.Text -> T.Text -> IO (Maybe Post.Post)+getPostFromFile date title = do+  let postPath = T.unpack $ mconcat ["_posts/", date, "-", title, ".md"]+  getFromFile Post.toPost postPath++getFromFile :: (T.Text -> Maybe a) -> String -> IO (Maybe a)+getFromFile constructor path = do+  fileContent <- (T.decodeUtf8' <$> BSL.readFile path) `catchIOError` const (pure $ Left undefined)+  let cont = case fileContent of+              Left _  -> Nothing+              Right x -> Just x+  let content = constructor =<< cont+  pure content++getAllTags :: [Post.Post] -> [T.Text]+getAllTags = getAll Post.tags++hasTag :: T.Text -> Post.Post -> Bool+hasTag tag = ([]/=) . filter (==tag) . Post.tags++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+
+ src/Web/Hablog/Run.hs view
@@ -0,0 +1,84 @@+-- | Running Hablog++{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Run where++import           Web.Scotty.Trans+import           Web.Scotty.TLS (scottyTTLS)+import           Control.Monad.Trans.Reader (runReaderT)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Text.Blaze.Html.Renderer.Text as HR+import qualified Network.Mime as Mime (defaultMimeLookup)++import Web.Hablog.Types+import Web.Hablog.Config+import Web.Hablog.Present+import Web.Hablog.Html (errorPage)+import Web.Hablog.Post (eqY, eqYM, eqDate)+++-- | Run Hablog on HTTP+run :: Config -> Int -> IO ()+run cfg port =+  scottyT port (`runReaderT` cfg) router++-- | Run Hablog on HTTPS+runTLS :: TLSConfig -> Config -> IO ()+runTLS tlsCfg cfg =+  scottyTTLS (blogTLSPort tlsCfg) (blogKey tlsCfg) (blogCert tlsCfg) (`runReaderT` cfg) router++-- | Hablog's router+router :: Hablog ()+router = do+  get "/" presentMain+  get "/post/:yyyy/:mm/:dd/:title" $ do+    (yyyy, mm, dd) <- getDate+    title <- param "title"+    presentPost (mconcat [yyyy,"/",mm,"/",dd, "/", title])+  get (regex "/static/(.*)") $ do+    path <- fmap (drop 1 . T.unpack) (param "0")+    if hasdots path then+      fail "no dots in path allowed"+      else do+        let mime = Mime.defaultMimeLookup (T.pack path)+        setHeader "content-type" $ TL.fromStrict (T.decodeUtf8 mime)+        file path+  get "/post/:yyyy/:mm/:dd" $ do+    (yyyy, mm, dd) <- getDate+    showPostsWhere (eqDate (yyyy, mm, dd))+  get "/post/:yyyy/:mm" $ do+    yyyy <- param "yyyy"+    mm <- param "mm"+    showPostsWhere (eqYM (yyyy, mm))+  get "/post/:yyyy" $ do+    yyyy <- param "yyyy"+    showPostsWhere (eqY yyyy)+  get "/tags"+    presentTags+  get "/tags/:tag" $ do+    tag <- param "tag"+    presentTag tag+  get "/authors"+    presentAuthors+  get "/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."++  where+    getDate =  (,,)+           <$> param "yyyy"+           <*> param "mm"+           <*> param "dd"++    hasdots [] = False+    hasdots ('.':'.':_) = True+    hasdots (_:rest) = hasdots rest
+ src/Web/Hablog/Types.hs view
@@ -0,0 +1,18 @@+ -- | Types to define Hablog over ScottyT++{-# LANGUAGE OverloadedStrings #-}++module Web.Hablog.Types where++import Data.Text.Lazy (Text)+import Web.Scotty.Trans (ScottyT, ActionT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask)++import Web.Hablog.Config (Config)++type Hablog = ScottyT Text (ReaderT Config IO)+type HablogAction = ActionT Text (ReaderT Config IO)++getCfg :: HablogAction Config+getCfg = lift ask
+ src/Web/Hablog/Utils.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.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+hd (x:_) = Just x++at :: [a] -> Int -> Maybe a+at [] _ = Nothing+at (x:xs) n+  | n > 0 = xs `at` (n-1)+  | n == 0 = Just x+  | otherwise = reverse xs `at` (-n)++headerBreaker :: T.Text+headerBreaker = "---"++takeJust :: [Maybe a] -> Maybe a+takeJust [] = Nothing+takeJust (Just x:_) = Just x+takeJust (Nothing:xs) = takeJust xs++convert :: Char -> [String] -> String+convert c str = concatMap (++[c]) (init str) ++ last str++splitBy :: Char -> String -> [String]+splitBy c txt = map reverse $ go [] txt+  where go xs [] = [xs]+        go xs (y:ys)+          | y == c    = xs : go [] ys+          | otherwise = go (y:xs) ys++removeWhitespaces :: String -> String+removeWhitespaces = unwords . words++infixl 0 |>+(|>) :: a -> (a -> b) -> b+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+++