breve-0.0.3.0: src/Application.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
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
  ServerSettings {..} <- newServerSettings
  table               <- load urlTable

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

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

    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 done $ object ["link" .= (bindUrl ++ word)]
        Nothing  -> respond badRequest