breve/src/Application.hs

{-# LANGUAGE OverloadedStrings #-}
module Application where

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

import Data.Monoid
import Control.Monad.IO.Class  (liftIO)
import Data.Aeson hiding       (json)
import Data.Text               (Text)
import qualified Data.Text.Format as F

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


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


reply :: Status -> Text -> ActionT IO ()
reply code text = setStatus code >> render (message text)


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  -> reply status404 "404: does not exist"
      Just url -> do
        F.print "Resolved {} -> {} " (name, url)
        redirect url

  post "/" $ do
    url <- param "url"
    case url of
      Nothing  -> reply status400 "400: bad request"
      Just url -> do
        name <- liftIO (insert table url)
        F.print "Registered {} -> {} " (url, name)
        let link = url' <> name
        render (done link)

  post "api" $ do
    url <- param "url"
    case url of
      Nothing  -> do
        setStatus status400
        json $ object [ "error" .= ("bad request"       :: Text )
                      , "msg"   .= ("missing url field" :: Text ) ]
      Just url -> do
        name <- liftIO (insert table url)
        F.print "Registered {} -> {} " (url, name)
        json $ object [ "link"     .= (url' <> name)
                      , "name"     .= name
                      , "original" .= url ]