breve/Application.hs

{-# LANGUAGE OverloadedStrings #-}
module Application where

import Breve.Common
import Breve.UrlTable

import Web.Simple
import Web.Simple.Static
import Web.Simple.Templates
import Web.Frank

import Control.Applicative
import Control.Monad.IO.Class
import Text.Printf
import Data.Maybe
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8      as BS


app :: (Application -> IO ()) -> IO ()
app runner = do
  settings    <- newAppSettings
  (baseUrl,_) <- serverSettings
  table       <- records

  runner $ controllerApp settings $ do
    get "/" (render "index.html" ())
    get "/main.css" (serveStatic "layouts/main.css")

    get "/:word" $ do
      word <- queryParam' "word"
      url  <- liftIO (extract table word)
      case url of
        Just url -> do
          liftIO $ putStrLn (printf "Resolved %s -> %s" word url)
          respond $ redirectTo (BS.pack url)
        Nothing  -> respond notFound

    post "/short" $ do
      (form, _) <- parseForm
      case lookup "url" form of
        Just url' -> do
          let url = BS.unpack url'
          word    <- liftIO (insert table url)
          liftIO $ putStrLn (printf "Registered %s -> %s " url word)
          render "done.html" $ object ["link" .= (baseUrl ++ word)]
        Nothing  -> respond badRequest