diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/breve.cabal b/breve.cabal --- a/breve.cabal +++ b/breve.cabal @@ -1,5 +1,5 @@ name: breve -version: 0.5.0.0 +version: 0.5.1.0 synopsis: a url shortener description: @@ -34,7 +34,7 @@ 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-server, 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 --- a/src/Application.hs +++ b/src/Application.hs @@ -15,8 +15,9 @@ 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) @@ -29,12 +30,25 @@ -- API definition import Servant -import Servant.HTML.Blaze (HTML) -import Web.FormUrlEncoded (FromForm(..), parseUnique) +import Servant.HTML.Blaze (HTML) +import Web.FormUrlEncoded (FromForm(..), parseUnique) +import qualified Servant.RawM.Server as R -- * 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 App = Get '[HTML] Html - :<|> "static" :> Raw + :<|> "static" :> R.RawM :<|> Capture "name" Name :> Redirect :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html @@ -97,11 +111,19 @@ "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 @@ -- -- 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 @@ -- | 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 @@ -- * 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/Generator.hs b/src/Breve/Generator.hs --- a/src/Breve/Generator.hs +++ b/src/Breve/Generator.hs @@ -9,6 +9,7 @@ , intHash ) where +import Control.Monad (replicateM) import Control.Monad.State import System.Random import Crypto.Hash.SHA256 (hash) diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -8,6 +8,8 @@ , settings ) where +import Paths_breve (getDataFileName) + import Control.Monad (when) import System.Environment (lookupEnv) import System.Directory (doesFileExist, getXdgDirectory, XdgDirectory(..)) @@ -25,6 +27,7 @@ , 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 @@ 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 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,27 +7,26 @@ 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 @@ 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 @@ -- 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) diff --git a/src/Views.hs b/src/Views.hs --- a/src/Views.hs +++ b/src/Views.hs @@ -11,7 +11,7 @@ -- | The homepage index :: Html -index = template $ do +index = breveTemplate $ do H.form ! method "POST" $ do "your url:" input ! type_ "text" ! name "url" @@ -21,20 +21,20 @@ -- submitted successfully. Takes the resulting -- url as an argument. done :: Text -> Html -done url = template $ do +done url = breveTemplate $ do "here's your new link: " a ! href (toValue url) $ (toHtml url) -- | Displays a text message in the page center message :: Text -> Html -message = template . toHtml +message = breveTemplate . toHtml -- | The main Breve template -- -- Takes HTML code and embeds it in the -- inner page container. -template :: Html -> Html -template fill = +breveTemplate :: Html -> Html +breveTemplate fill = docTypeHtml $ do H.head $ do H.title "breve: url shortener" @@ -42,6 +42,7 @@ meta ! name "keywords" ! content "url, shortener" meta ! name "author" ! content "Michele Guerini Rocco" meta ! charset "utf-8" + meta ! name "color-scheme" ! content "dark" 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"