breve/src/Application.hs

52 lines
1.5 KiB
Haskell
Raw Normal View History

2015-04-10 23:25:52 +02:00
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
2015-04-08 12:47:56 +02:00
module Application where
2015-04-08 22:13:02 +02:00
import Breve.Common
import Breve.UrlTable
2015-04-09 17:11:27 +02:00
import Paths_breve (getDataFileName)
2015-04-08 12:47:56 +02:00
import Web.Frank
2015-04-09 17:11:27 +02:00
import Web.Simple
import Web.Simple.Static (serveStatic)
import Web.Simple.Templates (render)
2015-04-08 12:47:56 +02:00
2015-04-09 17:11:27 +02:00
import Control.Monad.IO.Class (liftIO)
import Text.Printf (printf)
2015-04-08 12:47:56 +02:00
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
2015-04-09 17:11:27 +02:00
logStr = liftIO . putStrLn
2015-04-08 12:47:56 +02:00
app :: (Application -> IO ()) -> IO ()
app runner = do
2015-04-10 23:25:52 +02:00
settings <- newAppSettings
ServerSettings {..} <- newServerSettings
table <- load urlTable
2015-04-08 12:47:56 +02:00
2015-04-10 22:28:34 +02:00
css <- getDataFileName "layouts/main.css"
index <- getDataFileName "views/index.html"
done <- getDataFileName "views/done.html"
2015-04-09 17:11:27 +02:00
2015-04-08 12:47:56 +02:00
runner $ controllerApp settings $ do
2015-04-10 22:28:34 +02:00
get "/" (render index ())
get "/main.css" (serveStatic css)
2015-04-08 12:47:56 +02:00
2015-04-11 18:51:15 +02:00
get "/:name" $ do
name <- queryParam' "name"
url <- liftIO (extract table name)
2015-04-08 13:56:05 +02:00
case url of
Just url -> do
2015-04-11 18:51:15 +02:00
logStr (printf "Resolved %s -> %s" name url)
2015-04-08 13:56:05 +02:00
respond $ redirectTo (BS.pack url)
Nothing -> respond notFound
2015-04-08 12:47:56 +02:00
post "/short" $ do
(form, _) <- parseForm
2015-04-09 17:11:27 +02:00
case BS.unpack <$> lookup "url" form of
Just url -> do
2015-04-11 18:51:15 +02:00
name <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url name)
render done $ object ["link" .= (bindUrl ++ name)]
2015-04-08 12:47:56 +02:00
Nothing -> respond badRequest