{-# 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 static <- getDataFileName "static/" index <- getDataFileName "views/index.html" done <- getDataFileName "views/done.html" runner $ controllerApp settings $ do get "/" (render index ()) get "/:file" $ do file <- queryParam' "file" serveStatic (static ++ file) 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