53 lines
1.5 KiB
Haskell
53 lines
1.5 KiB
Haskell
{-# 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
|
|
|
|
css <- getDataFileName "layouts/main.css"
|
|
index <- getDataFileName "views/index.html"
|
|
done <- getDataFileName "views/done.html"
|
|
|
|
runner $ controllerApp settings $ do
|
|
get "/" (render index ())
|
|
get "/main.css" (serveStatic css)
|
|
|
|
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 "/short" $ do
|
|
form <- fmap fst parseForm
|
|
case lookup "url" form of
|
|
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)]
|
|
Nothing -> respond badRequest
|