diff --git a/breve.cabal b/breve.cabal index c320f92..a830e23 100644 --- a/breve.cabal +++ b/breve.cabal @@ -34,7 +34,7 @@ executable breve DataKinds, KindSignatures, TypeOperators build-depends: base >=4.8 && <5.0, warp, warp-tls, tls, blaze-html, - servant, servant-server, servant-blaze, + servant-server, servant-rawm, servant-blaze, wai, wai-extra, streaming-commons, http-api-data, mtl, text, aeson, bytestring, binary, diff --git a/src/Application.hs b/src/Application.hs index da3e885..01e9c72 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -15,8 +15,9 @@ import Breve.UrlTable import Views -- Misc -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.IO as T +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, runReaderT, asks) +import qualified Data.Text.IO as T -- JSON conversion import Data.Text (Text) @@ -30,11 +31,24 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtml) -- API definition import Servant import Servant.HTML.Blaze (HTML) +import Servant.RawM as R import Web.FormUrlEncoded (FromForm(..), parseUnique) -- * Types +-- | Custom handler type with a +-- reader environment +type AppM = ReaderT AppEnv Handler + +-- | The environment associated +-- to 'AppM' +data AppEnv = AppEnv + { bindUrl :: Text + , urlTable :: UrlTable + , staticDir :: FilePath + } + -- | API successful reply -- -- This is the reply returned by the JSON API @@ -82,7 +96,7 @@ type Breve = API :<|> App -- +----------+------+----------------------+ type App = Get '[HTML] Html - :<|> "static" :> Raw + :<|> "static" :> RawM :<|> Capture "name" Name :> Redirect :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html @@ -97,11 +111,19 @@ type API = "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply -- | Breve application -breve :: FilePath -- ^ static assets path - -> Url -- ^ bind url - -> UrlTable -- ^ url hashtable - -> Application -breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table) +-- +-- Notes: +-- +-- * @api@ is an empty value that brings the type +-- 'Breve' to the 'serve' function. If Haskell were +-- depedently typed it would just be @serve Breve@ +-- +-- * hoistServer flattens the AppM monad stack +-- in the breveServer definition +breve :: AppEnv -> Application +breve env = serve api (hoistServer api nt breveServer) + where api = Proxy :: Proxy Breve + nt x = runReaderT x env -- | Empty application -- @@ -117,22 +139,26 @@ emptyApp = serve (Proxy :: Proxy EmptyAPI) emptyServer -- -- 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 +-- +-- Note: 'RawM' is required because Servant doesn't +-- allow the creation of a raw 'Application' from a +-- monadic value. +breveServer :: ServerT Breve AppM +breveServer = api :<|> app + where app = homepage + :<|> (R.serveDirectoryWebApp =<< asks staticDir) + :<|> resolver + :<|> uploader -- | Serves the homepage -homepage :: Handler Html +homepage :: AppM 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) +resolver :: Name -> AppM Redirection +resolver name = do + table <- asks urlTable + url <- liftIO (extract table name) case url of Nothing -> throwError $ err404 { errBody = renderHtml (message "404: not found") } @@ -143,19 +169,23 @@ resolver table name = do -- | Takes a 'UrlForm' via POST -- and prints the shortned one -uploader :: Url -> UrlTable -> UrlForm -> Handler Html -uploader bindUrl table (UrlForm url) = do - name <- liftIO (insert table url) +uploader :: UrlForm -> AppM Html +uploader (UrlForm url) = do + table <- asks urlTable + bind <- asks bindUrl + name <- liftIO (insert table url) logStr ("Registered " <> url <> " -> " <> name) - pure (done $ bindUrl <> name) + pure (done $ bind <> name) -- | Takes a 'Url' via POST and returns -- the shortned one in an 'ApiReply' as JSON. -api :: Url -> UrlTable -> UrlForm -> Handler ApiReply -api bindUrl table (UrlForm url) = do - name <- liftIO (insert table url) +api :: UrlForm -> AppM ApiReply +api (UrlForm url) = do + table <- asks urlTable + bind <- asks bindUrl + name <- liftIO (insert table url) logStr ("Registered " <> url <> " -> " <> name) - pure $ ApiReply { link = (bindUrl <> name) + pure $ ApiReply { link = (bind <> name) , name = name , original = url } @@ -163,7 +193,7 @@ api bindUrl table (UrlForm url) = do -- * Misc -- | Handy function to log to stdout -logStr :: Text -> Handler () +logStr :: Text -> AppM () logStr = liftIO . T.putStrLn . ("[breve] " <>) -- | Verb that encodes an HTTP 302 redirection diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs index 4658b56..e95deac 100644 --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -8,6 +8,8 @@ module Breve.Settings , settings ) where +import Paths_breve (getDataFileName) + import Control.Monad (when) import System.Environment (lookupEnv) import System.Directory (doesFileExist, getXdgDirectory, XdgDirectory(..)) @@ -25,6 +27,7 @@ data AppSettings = AppSettings , bindPort :: Int -- ^ the port to bind to , bindUrl :: Text -- ^ the url used to reach breve , urlTable :: FilePath -- ^ path where to save the url table + , staticDir :: FilePath -- ^ path of the static assets , tlsSettings :: TLSSettings -- ^ warp TLS settings } @@ -56,14 +59,16 @@ settings path = do url = "https://" <> host <> port <> "/" baseURL <- lookupDefault url config "baseurl" + static <- getDataFileName "static/" createEmptyIfMissing urls return AppSettings - { bindHost = host - , bindPort = portnum - , bindUrl = baseURL - , urlTable = urls + { bindHost = host + , bindPort = portnum + , bindUrl = baseURL + , urlTable = urls + , staticDir = static , tlsSettings = (tlsSettingsChain cert chain key) { tlsAllowedVersions = [TLS12, TLS11] , tlsCiphers = ciphersuite_strong diff --git a/src/Main.hs b/src/Main.hs index 8ed2db1..0f3bfb2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,27 +7,26 @@ run the Breve webserver. module Main where -- Breve modules -import Application (breve, emptyApp) -import Breve.Settings +import Application (AppEnv(..), breve, emptyApp) +import Breve.Settings (AppSettings(..), settings) import Breve.UrlTable -import Paths_breve (getDataFileName) -- Data conversions -import Data.Text (Text, unpack) import Data.String (IsString(..)) import Data.Maybe (listToMaybe) +import Data.Text (unpack) -- IO -import Control.Monad (when, void) -import Control.Exception as E -import Control.Concurrent (forkIO) -import System.Environment (getArgs) -import Data.Text.IO as T +import Data.Text.IO as T +import Control.Exception as E +import Control.Monad (when, void) +import Control.Concurrent (forkIO) +import System.Environment (getArgs) -- Web server import Servant (Application) import Network.Wai.Handler.Warp (run, defaultSettings, setPort, setHost) -import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) +import Network.Wai.Handler.WarpTLS (runTLS) -- Middlewares import Network.Wai.Middleware.RequestLogger (logStdout) @@ -54,7 +53,6 @@ main = do configPath <- fmap listToMaybe getArgs config@(AppSettings{..}) <- settings configPath table <- load urlTable - static <- getDataFileName "static/" -- Redirect from HTTP to HTTPS when listening -- on the standard port @@ -69,6 +67,9 @@ main = do -- We use one here to add requests let middlewares = logStdout + -- The environment needed while running + let env = AppEnv bindUrl table staticDir + handle exit $ do T.putStrLn ("Serving on " <> bindUrl) - runApp config (middlewares $ breve static bindUrl table) + runApp config (middlewares $ breve env)