breve/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.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

  static <- getDataFileName "static/"
  index  <- getDataFileName "views/index.html"
  done   <- getDataFileName "views/done.html"

  runner $ controllerApp settings $ do
    get "/" (render index ())

    get "/:file" $ do
      file <- queryParam' "file"
      serveStatic (static ++ file)

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

    post "/" $ do
      form <- fst <$> parseForm
      case lookup "url" form of
        Nothing   -> respond badRequest
        Just url' -> do
          let url = BS.unpack url'
          name <- liftIO (insert table url)
          logStr (printf "Registered %s -> %s " url name)
          render done $ object ["link" .= (bindUrl ++ name)]

    post "/api" $ do
      form <- fst <$> parseForm
      case lookup "url" form of
        Nothing   -> respond badRequest
        Just url' -> do
          let url = BS.unpack url'
          name <- liftIO (insert table url)
          logStr (printf "Registered %s -> %s " url name)
          let json = object [ "link"     .= (bindUrl ++ name)
                            , "name"     .= name
                            , "original" .= url ]
          respond $ okHtml (encode json)