diff --git a/src/Application.hs b/src/Application.hs index dfb27fd..b470cbe 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,68 +1,63 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} module Application where -import Breve.Common +import Breve.Generator import Breve.UrlTable import Paths_breve (getDataFileName) - -import Web.Frank -import Web.Simple -import Web.Simple.Static (serveStatic) -import Web.Simple.Templates (render) +import Views 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 +import Data.Monoid +import Data.Text (pack, unpack) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Text.Lazy (toStrict) -logStr = liftIO . putStrLn +import Web.Spock.Safe +import Network.Wai.Middleware.Static -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" +logStr :: String -> ActionT IO () +logStr = liftIO . putStrLn - runner $ controllerApp settings $ do - get "/" (render index ()) - get "/:file" $ do - file <- queryParam' "file" - serveStatic (static ++ file) +serveStatic :: FilePath -> SpockT IO () +serveStatic = middleware . staticPolicy . addBase - 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 "/" $ do - form <- fst <$> parseForm - case lookup "url" form of - Nothing -> respond badRequest - 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)] +app :: Url -> UrlTable -> SpockT IO () +app url' table = do + liftIO (getDataFileName "static/") >>= serveStatic - post "/api" $ do - form <- fst <$> parseForm - case lookup "url" form of - Nothing -> respond badRequest - Just url' -> do - let url = BS.unpack url' - name <- liftIO (insert table url) - logStr (printf "Registered %s -> %s " url name) - let json = object [ "link" .= (bindUrl ++ name) - , "name" .= name - , "original" .= url ] - respond $ okHtml (encode json) + get "/" $ html (render index) + + get var $ \name -> do + url <- liftIO (extract table name) + case url of + Nothing -> html (render $ message "404: this one does not exist") + Just url -> do + logStr (printf "Resolved %s -> %s" name url) + redirect (pack url) + + post root $ do + url <- fmap unpack <$> param "url" + case url of + Nothing -> html (render $ message "bad request") + Just url -> do + name <- liftIO (insert table url) + logStr (printf "Registered %s -> %s " url name) + let link = url' <> name + html (render $ done link) + + post "api" $ do + url <- fmap unpack <$> param "url" + case url of + Nothing -> text "bad request" + Just url -> do + name <- liftIO (insert table url) + logStr (printf "Registered %s -> %s " url name) + let json = object [ "link" .= pack (url' <> name) + , "name" .= name + , "original" .= url ] + text (toStrict $ decodeUtf8 $ encode json) diff --git a/src/Main.hs b/src/Main.hs index ad054bc..5e17bd0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,14 +1,23 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} import Application -import Breve.Common +import Breve.Settings +import Breve.UrlTable + +import Web.Spock.Safe + + +runBreve :: Int -> SpockT IO () -> IO () +runBreve port app = runSpock port (spockT id app) -import Control.Applicative -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger main :: IO () main = do - ServerSettings {..} <- newServerSettings + AppSettings { bindUrl + , bindPort + , urlTable } <- settings + table <- load urlTable + putStrLn ("Serving on " ++ bindUrl) - app (runSettings warpSettings . logStdout) \ No newline at end of file + runBreve bindPort (app bindUrl table) + \ No newline at end of file