breve-0.0.2.0: src/Application.hs

{-# LANGUAGE OverloadedStrings #-}
module Application where

import Breve.Common
import Breve.UrlTable
import Paths_breve             (getDataFileName)

import Web.Frank
import Web.Simple
import Web.Simple.Static       (serveStatic)
import Web.Simple.Templates    (render)

import Control.Applicative
import Control.Monad.IO.Class  (liftIO)
import Text.Printf             (printf)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8      as BS

logStr = liftIO . putStrLn 

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

  cssPath   <- getDataFileName "layouts/main.css"
  indexPath <- getDataFileName "views/index.html"
  donePath  <- getDataFileName "views/done.html"

  runner $ controllerApp settings $ do
    get "/" (render indexPath ())
    get "/main.css" (serveStatic cssPath)

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

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