{-# 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.Applicative 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 "/:word" $ do word <- queryParam' "word" url <- liftIO (extract table word) case url of Just url -> do logStr (printf "Resolved %s -> %s" word url) respond $ redirectTo (BS.pack url) Nothing -> respond notFound post "/short" $ do (form, _) <- parseForm case BS.unpack <$> lookup "url" form of Just url -> do word <- liftIO (insert table url) logStr (printf "Registered %s -> %s " url word) render done $ object ["link" .= (bindUrl ++ word)] Nothing -> respond badRequest