use a ReaderT to pass environment around

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,

src/Application.hs

@@ -15,8 +15,9 @@ import Breve.UrlTable
 import Views
 
 -- Misc
-import Control.Monad.IO.Class  (liftIO)
+import Control.Monad.IO.Class   (liftIO)
-import qualified Data.Text.IO  as T
+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
+-- Notes:
-      -> UrlTable    -- ^ url hashtable
+--
-      -> Application
+-- * @api@ is an empty value that brings the type
-breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table)
+-- '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 =
+-- Note: 'RawM' is  required because Servant doesn't
-  api url table :<|> app
+-- allow the creation of a raw 'Application' from a
-    where app = homepage                    :<|>
+-- monadic value.
-                serveDirectoryWebApp static :<|>
+breveServer :: ServerT Breve AppM
-                resolver table              :<|>
+breveServer = api :<|> app
-                uploader url table
+  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 :: Name -> AppM Redirection
-resolver table name = do
+resolver name = do
-  url <- liftIO (extract table name)
+  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 :: UrlForm -> AppM Html
-uploader bindUrl table (UrlForm url) = do
+uploader (UrlForm url) = do
-  name <- liftIO (insert table url)
+  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 :: UrlForm -> AppM ApiReply
-api bindUrl table (UrlForm url) = do
+api (UrlForm url) = do
-  name <- liftIO (insert table url)
+  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

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
+    { bindHost  = host
-    , bindPort = portnum
+    , bindPort  = portnum
-    , bindUrl  = baseURL
+    , bindUrl   = baseURL
-    , urlTable = urls
+    , urlTable  = urls
+    , staticDir = static
     , tlsSettings = (tlsSettingsChain cert chain key)
       { tlsAllowedVersions = [TLS12, TLS11]
       , tlsCiphers = ciphersuite_strong

src/Main.hs

@@ -7,27 +7,26 @@ run the Breve webserver.
 module Main where
 
 -- Breve modules
-import Application     (breve, emptyApp)
+import Application     (AppEnv(..), breve, emptyApp)
-import Breve.Settings
+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 Data.Text.IO        as T
-import Control.Exception  as E 
+import Control.Exception   as E
-import Control.Concurrent (forkIO)
+import Control.Monad       (when, void)
-import System.Environment (getArgs)
+import Control.Concurrent  (forkIO)
-import Data.Text.IO       as T
+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)