49 lines
1.3 KiB
Haskell
49 lines
1.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Application where
|
|
|
|
import Breve.Common
|
|
import Breve.UrlTable
|
|
|
|
import Web.Simple
|
|
import Web.Simple.Static
|
|
import Web.Simple.Templates
|
|
import Web.Frank
|
|
|
|
import Control.Applicative
|
|
import Control.Monad.IO.Class
|
|
import Text.Printf
|
|
import Data.Maybe
|
|
import Data.Aeson
|
|
import qualified Data.ByteString.Lazy.Char8 as BL
|
|
import qualified Data.ByteString.Char8 as BS
|
|
|
|
|
|
app :: (Application -> IO ()) -> IO ()
|
|
app runner = do
|
|
settings <- newAppSettings
|
|
(baseUrl,_) <- serverSettings
|
|
table <- records
|
|
|
|
runner $ controllerApp settings $ do
|
|
get "/" (render "index.html" ())
|
|
get "/main.css" (serveStatic "layouts/main.css")
|
|
|
|
get "/:word" $ do
|
|
word <- queryParam' "word"
|
|
url <- liftIO (extract table word)
|
|
case url of
|
|
Just url -> do
|
|
liftIO $ putStrLn (printf "Resolved %s -> %s" word url)
|
|
respond $ redirectTo (BS.pack url)
|
|
Nothing -> respond notFound
|
|
|
|
post "/short" $ do
|
|
(form, _) <- parseForm
|
|
case lookup "url" form of
|
|
Just url' -> do
|
|
let url = BS.unpack url'
|
|
word <- liftIO (insert table url)
|
|
liftIO $ putStrLn (printf "Registered %s -> %s " url word)
|
|
render "done.html" $ object ["link" .= (baseUrl ++ word)]
|
|
Nothing -> respond badRequest
|