breve/src/Application.hs

{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
module Application where

import Breve.Generator
import Breve.UrlTable
import Paths_breve             (getDataFileName)
import Views

import Control.Monad.IO.Class  (liftIO)
import Text.Printf             (printf)
import Data.Aeson hiding       (json)
import Data.Monoid
import Data.Text               (pack, unpack)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy          (toStrict)

import Web.Spock.Safe
import Network.Wai (Middleware)
import Network.Wai.Middleware.Static
import Network.Wai.Middleware.RequestLogger

logStr :: String -> ActionT IO ()
logStr = liftIO . putStrLn


serveStatic :: FilePath -> Middleware
serveStatic = staticPolicy . addBase


app :: Url -> UrlTable -> SpockT IO ()
app url' table = do
  static <- liftIO (getDataFileName "static/")

  middleware (serveStatic static)
  middleware logStdout

  get "/" $ render index

  get var $ \name -> do
    url <- liftIO (extract table name)
    case url of
      Nothing  -> html (render $ message "404: this one does not exist")
      Just url -> do
        logStr (printf "Resolved %s -> %s" name url)
        redirect (pack url)

  post "/" $ do
    url <- fmap unpack <$> param "url"
    case url of
      Nothing  -> html (render $ message "bad request")
      Just url -> do
        name <- liftIO (insert table url)
        logStr (printf "Registered %s -> %s " url name)
        let link = url' <> name
        render (done link)

  post "api" $ do
    url <- fmap unpack <$> param "url"
    case url of
      Nothing  -> text "bad request"
      Just url -> do
        name <- liftIO (insert table url)
        logStr (printf "Registered %s -> %s " url name)
        json $ object [ "link"     .= pack (url' <> name)
                      , "name"     .= name
                      , "original" .= url ]