breve-0.3.0.0: src/Application.hs

{-# LANGUAGE OverloadedStrings #-}
module Application where

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

import Control.Monad.IO.Class  (liftIO)
import Text.Printf             (printf)
import Data.Aeson hiding       (json)
import Data.Monoid
import Data.Text               (pack, unpack)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy          (toStrict)

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

logStr :: String -> ActionT IO ()
logStr = liftIO . putStrLn


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


reply :: Status -> String -> 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
        logStr (printf "Resolved %s -> %s" name url)
        redirect (pack url)

  post "/" $ do
    url <- param "url"
    case unpack <$> url of
      Nothing  -> reply status400 "400: bad request"
      Just url -> do
        name <- liftIO (insert table url)
        logStr (printf "Registered %s -> %s " url name)
        let link = url' <> name
        render (done link)

  post "api" $ do
    url <- param "url"
    case unpack <$> url of
      Nothing  -> do
        setStatus status400
        json $ object [ "error" .= pack "bad request"
                      , "msg"   .= pack "missing url field" ]
      Just url -> do
        name <- liftIO (insert table url)
        logStr (printf "Registered %s -> %s " url name)
        json $ object [ "link"     .= pack (url' <> name)
                      , "name"     .= name
                      , "original" .= url ]