diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs diff --git a/breve.cabal b/breve.cabal --- 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: @@ -23,18 +23,21 @@ location: https://maxwell.ydns.eu/git/rnhmjoj/breve executable breve - main-is: Main.hs - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Application, Views, Breve.Settings, - 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, - transformers, mtl, - text, aeson, bytestring, binary, - hashtables, cryptohash, random, - xdg-basedir, configurator, directory - ghc-options: -threaded -O2 + main-is: Main.hs + hs-source-dirs: src + default-language: Haskell2010 + other-modules: Application, Views, Breve.Settings, + Breve.Generator, Breve.UrlTable, + Paths_breve + default-extensions: OverloadedStrings + other-extensions: RecordWildCards, DeriveGeneric, + DataKinds, KindSignatures, TypeOperators + build-depends: base >=4.8 && <5.0, + warp, warp-tls, tls, blaze-html, + servant, servant-server, servant-blaze, + wai, wai-extra, streaming-commons, http-api-data, + + mtl, text, aeson, bytestring, binary, + hashtables, cryptohash, random, + configurator, directory + ghc-options: -threaded -O2 "-with-rtsopts=-N -qg" diff --git a/src/Application.hs b/src/Application.hs --- a/src/Application.hs +++ b/src/Application.hs @@ -1,79 +1,175 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +{-| +This module contains the web application +and API implementation of Breve. +-} module Application where +-- Breve modules import Breve.Generator import Breve.UrlTable -import Paths_breve (getDataFileName) import Views -import Data.Monoid +-- Misc 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.Html.Renderer.Utf8 (renderHtml) -serveStatic :: FilePath -> Middleware -serveStatic = staticPolicy . addBase +-- API definition +import Servant +import Servant.HTML.Blaze (HTML) +import Web.FormUrlEncoded (FromForm(..), parseUnique) -reply :: Status -> Text -> ActionT IO () -reply code text = setStatus code >> render (message text) +-- * Types +-- | API successful reply +-- +-- This is the reply returned by the JSON 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 -logStr :: Text -> ActionT IO () -logStr = liftIO . T.putStrLn +instance ToJSON ApiReply +-- | This type is just a wrapper around a 'Text' +-- value. It's used to create a 'FromForm' instance +-- for a 'Url'. +newtype UrlForm = UrlForm Text -app :: Url -> UrlTable -> SpockT IO () -app url' table = do - static <- liftIO (getDataFileName "static/") +instance FromForm UrlForm where + fromForm f = UrlForm <$> parseUnique "url" f - middleware (serveStatic static) - middleware logStdout - get "/" $ render index +-- * Breve API - 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 +-- | API spec +-- +-- Breve has two main components: +-- +-- 1. the web app +-- 2. the JSON API itself +type Breve = API :<|> App - 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) +-- | Web app spec +-- +-- +----------+------+----------------------+ +-- | path | type | description | +-- +==========+======+======================+ +-- | / | GET | homepage | +-- +----------+------+----------------------+ +-- | / | POST | upload a new url | +-- +----------+------+----------------------+ +-- | /static | GET | static assets | +-- +----------+------+----------------------+ +-- | /:name | GET | resolves a short url | +-- +----------+------+----------------------+ +type App = + Get '[HTML] Html + :<|> "static" :> Raw + :<|> Capture "name" Name :> Redirect + :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html - 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 ] +-- | JSON API spec +-- +-- +----------+------+----------------------+ +-- | path | type | description | +-- +==========+======+======================+ +-- | /api | POST | upload a new url | +-- +----------+------+----------------------+ +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) -toTLS :: Text -> SpockT IO () -toTLS host = do - get var (redirect . new) - get "/" (redirect $ new "") - where new url = "https://" <> host <> "/" <> url +-- | Empty application +-- +-- This app does *nothing* but it's useful nonetheless: +-- it will be used as a basis to run the 'forceSSL' +-- middleware. +emptyApp :: Application +emptyApp = serve (Proxy :: Proxy EmptyAPI) emptyServer + +-- * 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 = renderHtml (message "404: not found") } + Just url -> do + logStr ("Resolved " <> name <> " -> " <> url) + pure (addHeader url NoContent) + + +-- | 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) + 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 -> UrlForm -> Handler ApiReply +api bindUrl table (UrlForm 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 . ("[breve] " <>) + +-- | 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 diff --git a/src/Breve/Generator.hs b/src/Breve/Generator.hs --- a/src/Breve/Generator.hs +++ b/src/Breve/Generator.hs @@ -1,8 +1,12 @@ +{-| +This module implements the algorithm +by which a URL is converted into a word. +-} module Breve.Generator -( nameHash -, intHash -, Name +( Name , Url +, nameHash +, intHash ) where import Control.Monad.State @@ -13,25 +17,32 @@ import Data.Text (Text, pack) import Data.Text.Encoding (encodeUtf8) +-- | A phonetic word associated to a URL type Name = Text + +-- | Any kind of URL type Url = Text --- Choose a random element of a list +-- | Takes a random element of a list choice :: [a] -> State StdGen a choice xs = (xs !!) <$> randomSt (0, length xs - 1) where randomSt = state . randomR --- Generate a random phonetic string +-- | Generates a random phonetic string word :: State StdGen Name word = pack <$> replicateM 10 letter where vowels = "aeiou" consonants = "bcdfghjklmnpqrstvwxyz" letter = choice [vowels, consonants] >>= choice --- SHA256 hash to seed a generator +-- | SHA256 hash to seed a generator intHash :: Url -> Int intHash = decode . fromStrict . hash . encodeUtf8 --- Assign a unique name to the url +-- | Assigns a unique name to the given URL +-- +-- The result is a computation based on a RNG +-- seeded by URL itself and is therefore +-- deterministic. nameHash :: Url -> Name nameHash = evalState word . mkStdGen . intHash diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -1,41 +1,47 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Breve.Settings where +{-| +This module defines the Breve configuration +parser and application settings. +-} +module Breve.Settings +( AppSettings(..) +, createEmptyIfMissing +, settings +) where -import Control.Monad (when) -import System.Environment (lookupEnv) -import System.Environment.XDG.BaseDir -import System.Directory (doesFileExist) -import Data.Text (Text, pack) +import Control.Monad (when) +import System.Environment (lookupEnv) +import System.Directory (doesFileExist, getXdgDirectory, XdgDirectory(..)) +import Data.Text (Text, pack) import Data.Configurator import Data.Monoid -import Network.Wai.Handler.WarpTLS (TLSSettings (..), tlsSettingsChain) -import Network.TLS (Version (..)) -import Network.TLS.Extra (ciphersuite_strong) +import Network.Wai.Handler.WarpTLS (TLSSettings (..), tlsSettingsChain) +import Network.TLS (Version (..)) +import Network.TLS.Extra (ciphersuite_strong) +-- | Breve settings data AppSettings = AppSettings - { bindHost :: Text - , bindPort :: Int - , bindUrl :: Text - , urlTable :: FilePath - , tlsSettings :: TLSSettings + { bindHost :: Text -- ^ the host to bind to + , bindPort :: Int -- ^ the port to bind to + , bindUrl :: Text -- ^ the url used to reach breve + , urlTable :: FilePath -- ^ path where to save the url table + , tlsSettings :: TLSSettings -- ^ warp TLS settings } - +-- | Initialises a file if it doesn't exist createEmptyIfMissing :: FilePath -> IO () createEmptyIfMissing file = do exists <- doesFileExist file when (not exists) (writeFile file "") - +-- | Configuration file parser settings :: Maybe FilePath -> IO AppSettings settings path = do configPath <- case path of Just path -> return path - Nothing -> getUserConfigFile "breve" "" + Nothing -> getXdgDirectory XdgConfig "breve" - urlsPath <- getUserDataFile "breve" "" + urlsPath <- getXdgDirectory XdgData "breve" config <- load [Required configPath] host <- lookupDefault "localhost" config "hostname" diff --git a/src/Breve/UrlTable.hs b/src/Breve/UrlTable.hs --- a/src/Breve/UrlTable.hs +++ b/src/Breve/UrlTable.hs @@ -1,6 +1,11 @@ +{-| +This modules defines the data structure used +to store the URLs in memory and on disk. +-} module Breve.UrlTable ( UrlTable , load +, save , insert , extract ) where @@ -12,16 +17,29 @@ import Text.Read (readMaybe) import qualified Data.HashTable.IO as H +-- | The hash table that stores URLs type UrlTable = H.CuckooHashTable Name Url --- Periodically write a url table to a file +-- | Periodically save a 'UrlTable' to a file sync :: UrlTable -> FilePath -> IO () sync table file = forever $ do threadDelay (round 3.0e8) + save table file + +-- | Writes a 'UrlTable' to a file +-- +-- The table is stored in a text file +-- as Haskell code for semplicity. +save :: UrlTable -> FilePath -> IO () +save table file = do content <- show <$> H.toList table writeFile file content + putStrLn "\n[breve] url table synced." --- Load a url table from a file +-- | Loads a URL table from a file +-- +-- Once the file is loaded it will be synced +-- periodically (every 5min) on the disk. load :: FilePath -> IO UrlTable load file = do content <- readFile file @@ -31,11 +49,11 @@ forkIO (sync table file) return table --- Insert the url in a table and return the name +-- | Insert the URL in a table and return the name insert :: UrlTable -> Url -> IO Name insert table url = H.insert table new url >> return new where new = nameHash url --- Lookup a table for the associated url +-- | Lookup a table for the associated URL extract :: UrlTable -> Name -> IO (Maybe Url) extract = H.lookup diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,40 +1,74 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} -import Application +{-| +This is the main module, which actually +run the Breve webserver. +-} +module Main where + +-- Breve modules +import Application (breve, emptyApp) import Breve.Settings import Breve.UrlTable +import Paths_breve (getDataFileName) -import Data.Text (Text, unpack) -import Data.Maybe (listToMaybe) +-- Data conversions +import Data.Text (Text, unpack) +import Data.String (IsString(..)) +import Data.Maybe (listToMaybe) + +-- IO +import Control.Monad (when, void) +import Control.Exception as E import Control.Concurrent (forkIO) -import Control.Monad import System.Environment (getArgs) - -import Web.Spock.Core -import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -import Network.Wai.Handler.Warp (run, defaultSettings, setPort) - -runBreve :: TLSSettings -> Int -> SpockT IO () -> IO () -runBreve tlsSettings port spock = - spockAsApp (spockT id spock) >>= runTLS tlsSettings settings - where settings = setPort port defaultSettings +import Data.Text.IO as T +-- Web server +import Servant (Application) +import Network.Wai.Handler.Warp (run, defaultSettings, setPort, setHost) +import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -runTLSRedirect :: Text -> IO () -runTLSRedirect = spockAsApp . spockT id . toTLS >=> run 80 +-- Middlewares +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.Wai.Middleware.ForceSSL (forceSSL) -forkIO' :: IO () -> IO () -forkIO' = fmap (const ()) . forkIO +-- * Helpers +-- | Runs Breve on the Warp webserver +runApp :: AppSettings -> Application -> IO () +runApp (AppSettings{..}) = + runTLS tlsSettings warpSettings + where + host = unpack bindHost + warpSettings = setPort bindPort $ + setHost (fromString host) defaultSettings +-- | Main +-- +-- Reads the configuration (given as the unique cli argument), +-- sets things accordingly and runs the webserver. 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) + -- Redirect from HTTP to HTTPS when listening + -- on the standard port + when (bindPort == 443) $ void $ + forkIO (run 80 $ forceSSL emptyApp) - putStrLn ("Serving on " ++ unpack bindUrl) - runBreve tlsSettings bindPort (app bindUrl table) + -- Save the table just before exiting + let exit E.UserInterrupt = save table urlTable + exit e = throwIO e + + -- Middlewares are functions (Application -> Application). + -- We use one here to add requests + let middlewares = logStdout + + handle exit $ do + T.putStrLn ("Serving on " <> bindUrl) + runApp config (middlewares $ breve static bindUrl table) diff --git a/src/Views.hs b/src/Views.hs --- a/src/Views.hs +++ b/src/Views.hs @@ -1,22 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} - +{-| +This module contains the HTML pages used by the +web application. These are all obtained by filling +a single template with the page structure. +-} 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 - -done :: Text -> Html -done url = template $ do - "here's your new link: " - a ! href (toValue url) $ (toHtml url) +import Data.Text (Text) +import Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes as A +-- | The homepage index :: Html index = template $ do H.form ! method "POST" $ do @@ -24,9 +17,22 @@ input ! type_ "text" ! name "url" input ! type_ "submit" ! value "go" +-- | The page shown when a new url has been +-- submitted successfully. Takes the resulting +-- url as an argument. +done :: Text -> Html +done url = template $ 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 +-- | The main Breve template +-- +-- Takes HTML code and embeds it in the +-- inner page container. template :: Html -> Html template fill = docTypeHtml $ do @@ -36,10 +42,10 @@ 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"