rewrite in Servant
This commit is contained in:
parent
f6f9ea1a17
commit
12fc50b89e
GPG Key ID:
BFBAF4C975F76450
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
65
src/Main.hs
65
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)
|
||||
|
||||
20
src/Views.hs
20
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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user