From 12fc50b89ea5200502354d9d7e3d512d1546f674 Mon Sep 17 00:00:00 2001 From: rnhmjoj Date: Wed, 6 Nov 2019 00:06:50 +0100 Subject: [PATCH] rewrite in Servant --- breve.cabal | 9 ++- src/Application.hs | 189 ++++++++++++++++++++++++++++++--------------- src/Main.hs | 65 ++++++++++------ src/Views.hs | 20 ++--- 4 files changed, 180 insertions(+), 103 deletions(-) diff --git a/breve.cabal b/breve.cabal index 9ad370b..aae636f 100644 --- a/breve.cabal +++ b/breve.cabal @@ -1,5 +1,5 @@ name: breve -version: 0.4.5.1 +version: 0.5.0.0 synopsis: a url shortener description: @@ -30,9 +30,10 @@ executable breve Breve.Generator, Breve.UrlTable, Paths_breve other-extensions: OverloadedStrings - build-depends: base >=4.8 && <5.0, warp, warp-tls, tls, - Spock, Spock-core, blaze-html, http-types, - wai, wai-middleware-static, wai-extra, + build-depends: base >=4.8 && <5.0, + warp, warp-tls, tls, blaze-html, blaze-markup, + servant-server, servant, servant-blaze, http-api-data, + wai, wai-extra, streaming-commons, transformers, mtl, text, aeson, bytestring, binary, hashtables, cryptohash, random, diff --git a/src/Application.hs b/src/Application.hs index 131ed53..f98c5d8 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,79 +1,144 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeSynonymInstances #-} + module Application where +-- Breve modules import Breve.Generator import Breve.UrlTable -import Paths_breve (getDataFileName) import Views +-- Misc import Data.Monoid import Control.Monad.IO.Class (liftIO) -import Data.Aeson hiding (json) -import Data.Text (Text) import qualified Data.Text.IO as T -import Web.Spock.Core -import Network.HTTP.Types.Status -import Network.Wai (Middleware) -import Network.Wai.Middleware.Static -import Network.Wai.Middleware.RequestLogger +-- JSON conversion +import Data.Text (Text) +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) + +-- HTML replies +import Text.Blaze.Html5 (Html) +import Text.Blaze.Renderer.Utf8 (renderMarkup) + +-- API definition +import Servant +import Servant.HTML.Blaze (HTML) +import Web.FormUrlEncoded (FromForm(..), parseUnique) +import GHC.TypeNats (Nat) -serveStatic :: FilePath -> Middleware -serveStatic = staticPolicy . addBase +-- * Types + +-- | API successful reply +-- This is the reply returned by the API +-- handler when the url has been shortned +-- successfully. +data ApiReply = ApiReply + { link :: Url -- ^ shortened url + , name :: Name -- ^ just the name + , original :: Url -- ^ original url + } deriving Generic + +instance ToJSON ApiReply + +instance FromForm Url where + fromForm f = parseUnique "url" f -reply :: Status -> Text -> ActionT IO () -reply code text = setStatus code >> render (message text) +-- * Breve API + +-- | API spec +-- +-- Breve has three main components: +-- 1. the web app +-- 2. the JSON API +-- 3. the static files server +type Breve = API :<|> App + +-- | Web app spec +type App = + Get '[HTML] Html + :<|> "static" :> Raw + :<|> Capture "name" Name :> Redirect + :<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html + +-- | JSON API spec +type API = + "api" :> ReqBody '[FormUrlEncoded] Url :> Post '[JSON] ApiReply + +-- | Verb that encodes an HTTP 302 redirection +type Redirect = + Verb 'GET 302 '[PlainText] Redirection + +-- | Reply with Location redirect header +type Redirection = + Headers '[Header "Location" Text] NoContent -logStr :: Text -> ActionT IO () +-- | Breve application +-- +-- Breve takes as parameters the bind url and the urls table +breve :: FilePath -> Url -> UrlTable -> Application +breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table) + + +-- * Handlers + +-- | Breve server +-- +-- This is just an ordered collection of handlers +-- following the 'Breve' API spec. +breveServer :: FilePath -> Url -> UrlTable -> Server Breve +breveServer static url table = + api url table :<|> app + where app = homepage :<|> + serveDirectoryWebApp static :<|> + resolver table :<|> + uploader url table + +-- | Serves the homepage +homepage :: Handler Html +homepage = pure index + +-- | Resolves a 'Name' to the full 'Url' +resolver :: UrlTable -> Name -> Handler Redirection +resolver table name = do + url <- liftIO (extract table name) + case url of + Nothing -> + throwError $ err404 { errBody = renderMarkup (message "404: not found") } + Just url -> do + logStr ("Resolved " <> name <> " -> " <> url) + pure (addHeader url NoContent) + + +-- | Takes a 'Url' via POST +-- and prints the shortned one +uploader :: Url -> UrlTable -> Url -> Handler Html +uploader bindUrl table url = do + name <- liftIO (insert table url) + logStr ("Registered " <> url <> " -> " <> name) + pure (done $ bindUrl <> name) + +-- Takes a 'Url' via POST and returns +-- the shortned one in an 'ApiReply' as JSON. +api :: Url -> UrlTable -> Url -> Handler ApiReply +api bindUrl table url = do + name <- liftIO (insert table url) + logStr ("Registered " <> url <> " -> " <> name) + pure $ ApiReply { link = (bindUrl <> name) + , name = name + , original = url + } + +-- * Misc + +-- | Handy function to log to stdout +logStr :: Text -> Handler () logStr = liftIO . T.putStrLn - - -app :: Url -> UrlTable -> SpockT IO () -app url' table = do - static <- liftIO (getDataFileName "static/") - - middleware (serveStatic static) - middleware logStdout - - get "/" $ render index - - get var $ \name -> do - url <- liftIO (extract table name) - case url of - Nothing -> reply status404 "404: does not exist" - Just url -> do - logStr ("Resolved " <> name <> " -> " <> url) - redirect url - - post "/" $ do - url <- param "url" - case url of - Nothing -> reply status400 "400: bad request" - Just url -> do - name <- liftIO (insert table url) - logStr ("Registered " <> url <> " -> " <> name) - render (done $ url' <> name) - - post "api" $ do - url <- param "url" - case url of - Nothing -> do - setStatus status400 - json $ object [ "error" .= ("bad request" :: Text ) - , "msg" .= ("missing url field" :: Text ) ] - Just url -> do - name <- liftIO (insert table url) - logStr ("Registered " <> url <> " -> " <> name) - json $ object [ "link" .= (url' <> name) - , "name" .= name - , "original" .= url ] - - -toTLS :: Text -> SpockT IO () -toTLS host = do - get var (redirect . new) - get "/" (redirect $ new "") - where new url = "https://" <> host <> "/" <> url diff --git a/src/Main.hs b/src/Main.hs index c916246..bf1b07e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,40 +1,57 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- Breve modules import Application import Breve.Settings import Breve.UrlTable +import Paths_breve (getDataFileName) -import Data.Text (Text, unpack) -import Data.Maybe (listToMaybe) -import Control.Concurrent (forkIO) -import Control.Monad +-- Data conversions +import Data.Text (Text, unpack) +import Data.String (IsString(..)) +import Data.Maybe (listToMaybe) + +-- IO import System.Environment (getArgs) +import Data.Text.IO as T -import Web.Spock.Core -import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -import Network.Wai.Handler.Warp (run, defaultSettings, setPort) +-- Web server +import Servant (Application) +import Network.Wai.Handler.Warp (defaultSettings, setPort, setHost) +import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -runBreve :: TLSSettings -> Int -> SpockT IO () -> IO () -runBreve tlsSettings port spock = - spockAsApp (spockT id spock) >>= runTLS tlsSettings settings - where settings = setPort port defaultSettings +-- Middlewares +import Network.Wai.Middleware.ForceSSL (forceSSL) +import Network.Wai.Middleware.RequestLogger (logStdout) -runTLSRedirect :: Text -> IO () -runTLSRedirect = spockAsApp . spockT id . toTLS >=> run 80 - - -forkIO' :: IO () -> IO () -forkIO' = fmap (const ()) . forkIO +-- * Helpers +-- | Runs Breve on the Warp webserver +run :: AppSettings -> Application -> IO () +run (AppSettings{..}) = + runTLS tlsSettings warpSettings + where + host = unpack bindHost + warpSettings = setPort bindPort $ + setHost (fromString host) defaultSettings +-- | Main +-- +-- Reads the config (given as the unique argument) +-- and runs the breve web app main :: IO () main = do - configPath <- fmap listToMaybe getArgs - AppSettings {..} <- settings configPath - table <- load urlTable + configPath <- fmap listToMaybe getArgs + config@(AppSettings{..}) <- settings configPath + table <- load urlTable + static <- getDataFileName "static/" - when (bindPort == 443) (forkIO' $ runTLSRedirect bindHost) + let + middlewares = + logStdout . + (if bindPort == 433 then forceSSL else id) - putStrLn ("Serving on " ++ unpack bindUrl) - runBreve tlsSettings bindPort (app bindUrl table) + T.putStrLn ("Serving on " <> bindUrl) + run config (middlewares $ breve static bindUrl table) diff --git a/src/Views.hs b/src/Views.hs index 57bffd5..6e42602 100644 --- a/src/Views.hs +++ b/src/Views.hs @@ -2,15 +2,9 @@ module Views where -import Data.Text (Text) -import Data.Text.Lazy (toStrict) -import Text.Blaze.Html.Renderer.Text (renderHtml) -import Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes as A -import qualified Web.Spock.Core as S - -render :: Html -> S.ActionT IO () -render = S.html . toStrict . renderHtml +import Data.Text (Text) +import Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes as A done :: Text -> Html done url = template $ do @@ -36,10 +30,10 @@ template fill = meta ! name "keywords" ! content "url, shortener" meta ! name "author" ! content "Michele Guerini Rocco" meta ! charset "utf-8" - link ! rel "stylesheet" ! href "main.css" ! type_ "text/css" - link ! rel "apple-touch-icon" ! href "icon-big.png" - link ! rel "icon" ! type_ "image/png" ! href "/icon-medium.png" ! sizes "96x96" - link ! rel "icon" ! type_ "image/png" ! href "/icon-small.png" ! sizes "16x16" + link ! rel "stylesheet" ! href "/static/main.css" ! type_ "text/css" + link ! rel "apple-touch-icon" ! href "static/icon-big.png" + link ! rel "icon" ! type_ "image/png" ! href "/static/icon-medium.png" ! sizes "96x96" + link ! rel "icon" ! type_ "image/png" ! href "/static/icon-small.png" ! sizes "16x16" body $ do header $ do h1 $ a ! href "/" $ "BREVE"