{-# LANGUAGE OverloadedStrings #-}
module Web.Hablog.Run where
import Data.Monoid
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 Network.URI (URI, parseURI)
import Control.Monad
import Data.Maybe
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 :: Config -> Int -> IO ()
run cfg port =
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')
runTLS :: TLSConfig -> Config -> IO ()
runTLS tlsCfg cfg =
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')
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 (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