-- | 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 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
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 :: Config -> Int -> IO ()
run cfg :: Config
cfg port :: Int
port =
  Int
-> (ReaderT Config IO Response -> IO Response)
-> ScottyT Text (ReaderT Config IO) ()
-> IO ()
forall (m :: * -> *) (n :: * -> *) e.
(Monad m, MonadIO n) =>
Int -> (m Response -> IO Response) -> ScottyT e m () -> n ()
scottyT Int
port (ReaderT Config IO Response -> Config -> IO Response
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Config
cfg') (Maybe URI -> ScottyT Text (ReaderT Config IO) ()
router (Maybe URI -> ScottyT Text (ReaderT Config IO) ())
-> Maybe URI -> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$! Maybe URI
domain)
  where
    cfg' :: Config
cfg' = Config
cfg
      { blogDomain :: Text
blogDomain = "http://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Config -> Text
blogDomain Config
cfg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
portStr }
    portStr :: Text
portStr = if Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 80 then "" else String -> Text
TL.pack (Int -> String
forall a. Show a => a -> String
show Int
port)
    domain :: Maybe URI
domain = String -> Maybe URI
parseURI (Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Config -> Text
blogDomain Config
cfg')

-- | Run Hablog on HTTPS
runTLS :: TLSConfig -> Config -> IO ()
runTLS :: TLSConfig -> Config -> IO ()
runTLS tlsCfg :: TLSConfig
tlsCfg cfg :: Config
cfg =
  Int
-> String
-> String
-> (ReaderT Config IO Response -> IO Response)
-> ScottyT Text (ReaderT Config IO) ()
-> IO ()
forall (m :: * -> *) (n :: * -> *) t.
(Monad m, MonadIO n) =>
Int
-> String
-> String
-> (m Response -> IO Response)
-> ScottyT t m ()
-> n ()
scottyTTLS (TLSConfig -> Int
blogTLSPort TLSConfig
tlsCfg) (TLSConfig -> String
blogKey TLSConfig
tlsCfg) (TLSConfig -> String
blogCert TLSConfig
tlsCfg) (ReaderT Config IO Response -> Config -> IO Response
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Config
cfg') (Maybe URI -> ScottyT Text (ReaderT Config IO) ()
router (Maybe URI -> ScottyT Text (ReaderT Config IO) ())
-> Maybe URI -> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$! Maybe URI
domain)
  where
    cfg' :: Config
cfg' = Config
cfg
      { blogDomain :: Text
blogDomain = "https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Config -> Text
blogDomain Config
cfg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
portStr }
    portStr :: Text
portStr = if TLSConfig -> Int
blogTLSPort TLSConfig
tlsCfg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 443 then "" else String -> Text
TL.pack (Int -> String
forall a. Show a => a -> String
show (TLSConfig -> Int
blogTLSPort TLSConfig
tlsCfg))
    domain :: Maybe URI
domain = String -> Maybe URI
parseURI (Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Config -> Text
blogDomain Config
cfg')

-- | Hablog's router
router :: Maybe URI -> Hablog ()
router :: Maybe URI -> ScottyT Text (ReaderT Config IO) ()
router domain :: Maybe URI
domain = do
  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get ("/favicon.ico") (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    let
      path :: String
path = "static/favicon.ico"
      mime :: MimeType
mime = FileName -> MimeType
Mime.defaultMimeLookup (String -> FileName
T.pack String
path)
    Text -> Text -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) e. Monad m => Text -> Text -> ActionT e m ()
setHeader "content-type" (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ FileName -> Text
TL.fromStrict (MimeType -> FileName
T.decodeUtf8 MimeType
mime)
    String -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) e. Monad m => String -> ActionT e m ()
file String
path

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get (String -> RoutePattern
regex "/static/(.*)") (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    String
path <- (FileName -> String)
-> ActionT Text (ReaderT Config IO) FileName
-> ActionT Text (ReaderT Config IO) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> (FileName -> String) -> FileName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
T.unpack) (Text -> ActionT Text (ReaderT Config IO) FileName
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "0")
    if String -> Bool
hasdots String
path then
      String -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "no dots in path allowed"
      else do
        let mime :: MimeType
mime = FileName -> MimeType
Mime.defaultMimeLookup (String -> FileName
T.pack String
path)
        Text -> Text -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) e. Monad m => Text -> Text -> ActionT e m ()
setHeader "content-type" (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ FileName -> Text
TL.fromStrict (MimeType -> FileName
T.decodeUtf8 MimeType
mime)
        String -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) e. Monad m => String -> ActionT e m ()
file String
path

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get (String -> RoutePattern
regex "(.*)") (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    String
path <- (FileName -> String)
-> ActionT Text (ReaderT Config IO) FileName
-> ActionT Text (ReaderT Config IO) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> (FileName -> String) -> FileName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
T.unpack) (Text -> ActionT Text (ReaderT Config IO) FileName
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "0")
    Bool
-> ActionT Text (ReaderT Config IO) ()
-> ActionT Text (ReaderT Config IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ("apple" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
path) (ActionT Text (ReaderT Config IO) ()
 -> ActionT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
next
    Maybe Text
agent <- Text -> ActionT Text (ReaderT Config IO) (Maybe Text)
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m (Maybe Text)
header "User-Agent"
    IO () -> ActionT Text (ReaderT Config IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionT Text (ReaderT Config IO) ())
-> IO () -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
      String
hablogDir <- (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "/.hablog") (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
hablogDir
      UTCTime
time <- IO UTCTime
getCurrentTime
      let
        date :: String
date = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale  "%F" UTCTime
time
        datetime :: String
datetime = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale  "%F %T" UTCTime
time
        replaceChar :: p -> p -> p -> p
replaceChar from :: p
from to :: p
to char :: p
char
          | p
char p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
from = p
to
          | Bool
otherwise = p
char
        entry :: String
entry = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ "\""
          , (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char -> Char
forall p. Eq p => p -> p -> p -> p
replaceChar '\"' '_' (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> Char -> Char
forall p. Eq p => p -> p -> p -> p
replaceChar ',' '_') String
path
          , "\" , "
          , String
date
          , " , "
          , String
datetime
          , " , "
          , "\""
          , String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" Text -> String
TL.unpack Maybe Text
agent
          , "\""
          , "\n"
          ]
      String -> String -> IO ()
appendFile (String
hablogDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "/visits.csv") String
entry
    ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a. (ScottyError e, Monad m) => ActionT e m a
next

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/" ActionT Text (ReaderT Config IO) ()
presentHome

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog" ActionT Text (ReaderT Config IO) ()
presentBlog

  Maybe URI -> ScottyT Text (ReaderT Config IO) ()
route Maybe URI
domain

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/:page" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
page <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "page"
    Text -> ActionT Text (ReaderT Config IO) ()
presentPage (Text -> Text
TL.toLower Text
page)

  ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
ActionT e m () -> ScottyT e m ()
notFound (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Config
cfg <- HablogAction Config
getCfg
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> Text -> String -> Html
errorPage Config
cfg (Config -> Text
blogTitle Config
cfg Text -> Text -> Text
`TL.append` " - 404: not found") "404 - Could not find the page you were looking for."

  where
    hasdots :: String -> Bool
hasdots [] = Bool
False
    hasdots ('.':'.':_) = Bool
True
    hasdots (_:rest :: String
rest) = String -> Bool
hasdots String
rest


route :: Maybe URI -> Hablog ()
route :: Maybe URI -> ScottyT Text (ReaderT Config IO) ()
route domain :: Maybe URI
domain = do
  Bool
-> ScottyT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe URI -> Bool
forall a. Maybe a -> Bool
isJust Maybe URI
domain)
    (ScottyT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ScottyT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/rss" (URI -> ActionT Text (ReaderT Config IO) ()
presentRSS (URI -> ActionT Text (ReaderT Config IO) ())
-> URI -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust Maybe URI
domain)

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/post/:yyyy/:mm/:dd/:title" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    (yyyy :: Text
yyyy, mm :: Text
mm, dd :: Text
dd) <- ActionT Text (ReaderT Config IO) (Text, Text, Text)
getDate
    Text
title <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "title"
    Text -> ActionT Text (ReaderT Config IO) ()
presentPost ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
yyyy,"/",Text
mm,"/",Text
dd, "/", Text
title])

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/post/:yyyy/:mm/:dd" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    (yyyy :: Text
yyyy, mm :: Text
mm, dd :: Text
dd) <- ActionT Text (ReaderT Config IO) (Text, Text, Text)
getDate
    (Post -> Bool) -> ActionT Text (ReaderT Config IO) ()
showPostsWhere ((Text, Text, Text) -> Post -> Bool
eqDate (Text
yyyy, Text
mm, Text
dd))

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/post/:yyyy/:mm" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
yyyy <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "yyyy"
    Text
mm <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "mm"
    (Post -> Bool) -> ActionT Text (ReaderT Config IO) ()
showPostsWhere ((Text, Text) -> Post -> Bool
eqYM (Text
yyyy, Text
mm))

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/post/:yyyy" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
yyyy <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "yyyy"
    (Post -> Bool) -> ActionT Text (ReaderT Config IO) ()
showPostsWhere (Text -> Post -> Bool
eqY Text
yyyy)

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/tags"
    ActionT Text (ReaderT Config IO) ()
presentTags

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/tags/:tag" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
tag <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "tag"
    Text -> ActionT Text (ReaderT Config IO) ()
presentTag Text
tag

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/authors"
    ActionT Text (ReaderT Config IO) ()
presentAuthors

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/blog/authors/:author" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
author <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "author"
    Text -> ActionT Text (ReaderT Config IO) ()
presentAuthor Text
author

  -- redirects

  Bool
-> ScottyT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe URI -> Bool
forall a. Maybe a -> Bool
isJust Maybe URI
domain)
    (ScottyT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ScottyT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/rss" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect "/blog/rss"

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/post/:yyyy/:mm/:dd/:title" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    (yyyy :: Text
yyyy, mm :: Text
mm, dd :: Text
dd) <- ActionT Text (ReaderT Config IO) (Text, Text, Text)
getDate
    Text
title <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "title"
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/post/", Text
yyyy, "/", Text
mm, "/", Text
dd, "/", Text
title]

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/post/:yyyy/:mm/:dd" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    (yyyy :: Text
yyyy, mm :: Text
mm, dd :: Text
dd) <- ActionT Text (ReaderT Config IO) (Text, Text, Text)
getDate
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/post/", Text
yyyy, "/", Text
mm, "/", Text
dd]

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/post/:yyyy/:mm" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
yyyy <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "yyyy"
    Text
mm <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "mm"
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/post/", Text
yyyy, "/", Text
mm]

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/post/:yyyy" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
yyyy <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "yyyy"
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/post/", Text
yyyy]

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/tags" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect "/blog/tags"

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/tags/:tag" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
tag <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "tag"
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/tags/", Text
tag]

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/authors" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect "/blog/authors"

  RoutePattern
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get "/authors/:author" (ActionT Text (ReaderT Config IO) ()
 -> ScottyT Text (ReaderT Config IO) ())
-> ActionT Text (ReaderT Config IO) ()
-> ScottyT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Text
author <- Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "author"
    Text -> ActionT Text (ReaderT Config IO) ()
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect (Text -> ActionT Text (ReaderT Config IO) ())
-> Text -> ActionT Text (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["/blog/authors/", Text
author]

  where
    getDate :: ActionT Text (ReaderT Config IO) (Text, Text, Text)
getDate =  (,,)
           (Text -> Text -> Text -> (Text, Text, Text))
-> ActionT Text (ReaderT Config IO) Text
-> ActionT
     Text (ReaderT Config IO) (Text -> Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "yyyy"
           ActionT
  Text (ReaderT Config IO) (Text -> Text -> (Text, Text, Text))
-> ActionT Text (ReaderT Config IO) Text
-> ActionT Text (ReaderT Config IO) (Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "mm"
           ActionT Text (ReaderT Config IO) (Text -> (Text, Text, Text))
-> ActionT Text (ReaderT Config IO) Text
-> ActionT Text (ReaderT Config IO) (Text, Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> ActionT Text (ReaderT Config IO) Text
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m a
param "dd"