Run.hs

-- | 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